version 1.2, 1998/12/08 22:02:58
|
version 1.3, 1999/05/20 13:38:28
|
Line 1
|
Line 1
|
\ builttag.fs |
\ builttag.fs |
|
|
\ Copyright (C) 1998 Free Software Foundation, Inc. |
0 [IF] |
|
|
\ This file is part of Gforth. |
This is a cross compiler extension. |
|
|
\ Gforth is free software; you can redistribute it and/or |
[THEN] |
\ modify it under the terms of the GNU General Public License |
|
\ as published by the Free Software Foundation; either version 2 |
base @ decimal |
\ of the License, or (at your option) any later version. |
|
|
|
\ This program is distributed in the hope that it will be useful, |
|
\ but WITHOUT ANY WARRANTY; without even the implied warranty of |
|
\ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
|
\ GNU General Public License for more details. |
|
|
|
\ You should have received a copy of the GNU General Public License |
|
\ along with this program; if not, write to the Free Software |
|
\ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. |
|
|
|
variable builtnr |
variable builtnr |
create linebuf 200 chars allot |
create linebuf 200 chars allot |
create filename 200 chars allot |
create filename 200 chars allot |
0 value fd |
0 value btfd |
|
|
: s' |
: s' |
[char] ' parse postpone sliteral ; immediate |
[char] ' parse postpone sliteral ; immediate |
|
|
|
[IFDEF] project-name |
|
: extractproject ( -- adr len ) project-name ; |
|
[ELSE] |
|
|
|
defined? sourcefilename 0= [IF] |
|
cr ." I need project-name defined for builttag" abort |
|
[THEN] |
|
|
|
: extractproject ( -- adr len ) |
|
sourcefilename 2dup >r >r |
|
BEGIN dup WHILE 1- |
|
2dup + c@ [char] . = IF r> drop r> drop EXIT THEN |
|
REPEAT 2drop r> r> ; |
|
|
|
[THEN] |
|
|
|
get-current >MINIMAL |
|
|
: builttag |
: builttag |
sourcefilename filename place |
base @ >r decimal |
'n filename count + 1 chars - c! |
extractproject filename place |
filename count r/o bin open-file |
s" .n" filename +place |
|
filename count r/o open-file |
IF drop 0 builtnr ! |
IF drop 0 builtnr ! |
ELSE >r linebuf 100 r@ read-line drop drop |
ELSE >r linebuf 100 r@ read-line drop drop |
linebuf swap 0 -rot 0 -rot >number 2drop drop 1+ |
linebuf swap 0 -rot 0 -rot >number 2drop drop 1+ |
builtnr ! r> close-file throw |
builtnr ! r> close-file throw |
THEN |
THEN |
filename count r/w bin create-file throw to fd |
filename count r/w create-file throw to btfd |
base @ >r decimal |
builtnr @ s>d <# #S #> btfd write-file throw |
builtnr @ s>d <# #S #> fd write-file throw |
s" constant built#" btfd write-line throw |
s" constant built#" fd write-line throw |
s' const create builtdate ," ' btfd write-file throw |
s' const create builtdate ," ' fd write-file throw |
|
time&date >r >r >r |
time&date >r >r >r |
s>d <# ': hold # # #> fd write-file throw |
s>d <# [char] : hold # # #> btfd write-file throw |
s>d <# bl hold # # #> fd write-file throw |
s>d <# bl hold # # #> btfd write-file throw |
drop |
drop |
r> s>d <# '. hold # # #> fd write-file throw |
r> s>d <# [char] . hold # # #> btfd write-file throw |
r> s>d <# '. hold # # #> fd write-file throw |
r> s>d <# [char] . hold # # #> btfd write-file throw |
r> s>d <# # # # # #> fd write-file throw |
r> s>d <# # # # # #> btfd write-file throw |
s' "' fd write-line throw |
s' "' btfd write-line throw |
s' : .built cr ." Built #" built# . ." Date " builtdate count type cr ;' |
s' : .built cr ." Built #" built# . ." Date " builtdate count type cr ;' |
fd write-line throw |
btfd write-line throw |
fd close-file throw |
btfd close-file throw |
filename count included |
filename count included |
r> base ! ; |
r> base ! ; |
|
|
|
set-current |
|
base ! |