Return to builttag.fs CVS log

Up to [gforth] / gforth / ec

Updated some ec stuff.

    1: \ builttag.fs
    2: 
    3: 0 [IF]
    4: 
    5: This is a cross compiler extension.
    6: 
    7: [THEN]
    8: 
    9: base @ decimal
   10: 
   11: variable builtnr
   12: create linebuf 200 chars allot
   13: create filename 200 chars allot
   14: 0 value btfd
   15: 
   16: : s'
   17:   [char] ' parse postpone sliteral ; immediate
   18: 
   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: 
   37: : builttag
   38:   base @ >r decimal
   39:   extractproject filename place
   40:   s" .n" filename +place
   41:   filename count r/o open-file 
   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
   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
   51:   time&date >r >r >r
   52:   s>d <# [char] : hold # # #> btfd write-file throw
   53:   s>d <# bl hold # # #> btfd write-file throw
   54:   drop
   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
   59:   s' : .built cr ." Built #" built# . ." Date " builtdate count type cr ;'
   60:   btfd write-line throw
   61:   btfd close-file throw
   62:   filename count included 
   63:   r> base ! ;
   64: 
   65: set-current
   66: base !