Annotation of gforth/ec/builttag.fs, revision 1.3
1.1 pazsan 1: \ builttag.fs
2:
1.3 ! jwilke 3: 0 [IF]
1.2 anton 4:
1.3 ! jwilke 5: This is a cross compiler extension.
1.2 anton 6:
1.3 ! jwilke 7: [THEN]
! 8:
! 9: base @ decimal
1.2 anton 10:
1.1 pazsan 11: variable builtnr
12: create linebuf 200 chars allot
13: create filename 200 chars allot
1.3 ! jwilke 14: 0 value btfd
1.1 pazsan 15:
16: : s'
17: [char] ' parse postpone sliteral ; immediate
18:
1.3 ! jwilke 19: [IFDEF] project-name
! 20: : extractproject ( -- adr len ) project-name ;
! 21: [ELSE]
! 22:
! 23: defined? sourcefilename 0= [IF]
! 24: cr ." I need project-name defined for builttag" abort
! 25: [THEN]
! 26:
! 27: : extractproject ( -- adr len )
! 28: sourcefilename 2dup >r >r
! 29: BEGIN dup WHILE 1-
! 30: 2dup + c@ [char] . = IF r> drop r> drop EXIT THEN
! 31: REPEAT 2drop r> r> ;
! 32:
! 33: [THEN]
! 34:
! 35: get-current >MINIMAL
! 36:
1.1 pazsan 37: : builttag
1.3 ! jwilke 38: base @ >r decimal
! 39: extractproject filename place
! 40: s" .n" filename +place
! 41: filename count r/o open-file
1.1 pazsan 42: IF drop 0 builtnr !
43: ELSE >r linebuf 100 r@ read-line drop drop
44: linebuf swap 0 -rot 0 -rot >number 2drop drop 1+
45: builtnr ! r> close-file throw
46: THEN
1.3 ! jwilke 47: filename count r/w create-file throw to btfd
! 48: builtnr @ s>d <# #S #> btfd write-file throw
! 49: s" constant built#" btfd write-line throw
! 50: s' const create builtdate ," ' btfd write-file throw
1.1 pazsan 51: time&date >r >r >r
1.3 ! jwilke 52: s>d <# [char] : hold # # #> btfd write-file throw
! 53: s>d <# bl hold # # #> btfd write-file throw
1.1 pazsan 54: drop
1.3 ! jwilke 55: r> s>d <# [char] . hold # # #> btfd write-file throw
! 56: r> s>d <# [char] . hold # # #> btfd write-file throw
! 57: r> s>d <# # # # # #> btfd write-file throw
! 58: s' "' btfd write-line throw
1.1 pazsan 59: s' : .built cr ." Built #" built# . ." Date " builtdate count type cr ;'
1.3 ! jwilke 60: btfd write-line throw
! 61: btfd close-file throw
1.1 pazsan 62: filename count included
63: r> base ! ;
1.3 ! jwilke 64:
! 65: set-current
! 66: base !
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>