version 1.32, 1995/03/13 09:17:31
|
version 1.38, 1995/06/07 10:05:06
|
Line 153 Defer source
|
Line 153 Defer source
|
\ word parse 23feb93py |
\ word parse 23feb93py |
|
|
: parse-word ( char -- addr len ) |
: parse-word ( char -- addr len ) |
source 2dup >r >r >in @ /string |
source 2dup >r >r >in @ over min /string |
rot dup bl = IF drop (parse-white) ELSE (word) THEN |
rot dup bl = IF drop (parse-white) ELSE (word) THEN |
2dup + r> - 1+ r> min >in ! ; |
2dup + r> - 1+ r> min >in ! ; |
: word ( char -- addr ) |
: word ( char -- addr ) |
parse-word here place bl here count + c! here ; |
parse-word here place bl here count + c! here ; |
|
|
: parse ( char -- addr len ) |
: parse ( char -- addr len ) |
>r source >in @ /string over swap r> scan >r |
>r source >in @ over min /string over swap r> scan >r |
over - dup r> IF 1+ THEN >in +! ; |
over - dup r> IF 1+ THEN >in +! ; |
|
|
\ name 13feb93py |
\ name 13feb93py |
Line 173 Defer source
|
Line 173 Defer source
|
2dup + r> - 1+ r> min >in ! ; |
2dup + r> - 1+ r> min >in ! ; |
\ name count ; |
\ name count ; |
|
|
|
: name-too-short? ( c-addr u -- c-addr u ) |
|
dup 0= -&16 and throw ; |
|
|
|
: name-too-long? ( c-addr u -- c-addr u ) |
|
dup $1F u> -&19 and throw ; |
|
|
\ Literal 17dec92py |
\ Literal 17dec92py |
|
|
: Literal ( n -- ) state @ IF postpone lit , THEN ; |
: Literal ( n -- ) state @ IF postpone lit , THEN ; |
Line 781 Avariable leave-sp leave-stack 3 cells
|
Line 787 Avariable leave-sp leave-stack 3 cells
|
: (S") "lit count ; restrict |
: (S") "lit count ; restrict |
: SLiteral postpone (S") here over char+ allot place align ; |
: SLiteral postpone (S") here over char+ allot place align ; |
immediate restrict |
immediate restrict |
: S" [char] " parse state @ IF postpone SLiteral THEN ; |
create s"-buffer /line chars allot |
|
: S" ( run-time: -- c-addr u ) |
|
[char] " parse |
|
state @ |
|
IF |
|
postpone SLiteral |
|
ELSE |
|
/line min >r s"-buffer r@ cmove |
|
s"-buffer r> |
|
THEN ; |
immediate |
immediate |
: ." state @ IF postpone (.") ," align |
: ." state @ IF postpone (.") ," align |
ELSE [char] " parse type THEN ; immediate |
ELSE [char] " parse type THEN ; immediate |
Line 794 Avariable leave-sp leave-stack 3 cells
|
Line 809 Avariable leave-sp leave-stack 3 cells
|
THEN |
THEN |
source >in ! drop ; immediate |
source >in ! drop ; immediate |
|
|
: G\ ( -- ) \ new backslash |
: \G ( -- ) \ new backslash |
POSTPONE \ ; immediate |
POSTPONE \ ; immediate |
|
|
\ error handling 22feb93py |
\ error handling 22feb93py |
Line 827 defer header ' (header) IS header
|
Line 842 defer header ' (header) IS header
|
dup c, here swap chars dup allot move ; |
dup c, here swap chars dup allot move ; |
|
|
: name, ( "name" -- ) |
: name, ( "name" -- ) |
name |
name name-too-short? name-too-long? |
dup $1F u> -&19 and throw ( is name too long? ) |
|
string, cfalign ; |
string, cfalign ; |
: input-stream-header ( "name" -- ) |
: input-stream-header ( "name" -- ) |
\ !! this is f83-implementation-dependent |
\ !! this is f83-implementation-dependent |
Line 854 create nextname-buffer 32 chars allot
|
Line 868 create nextname-buffer 32 chars allot
|
|
|
\ the next name is given in the string |
\ the next name is given in the string |
: nextname ( c-addr u -- ) \ general |
: nextname ( c-addr u -- ) \ general |
dup $1F u> -&19 and throw ( is name too long? ) |
name-too-long? |
nextname-buffer c! ( c-addr ) |
nextname-buffer c! ( c-addr ) |
nextname-buffer count move |
nextname-buffer count move |
['] nextname-header IS (header) ; |
['] nextname-header IS (header) ; |
Line 1161 Defer key
|
Line 1175 Defer key
|
\ : bin dup 1 chars - c@ |
\ : bin dup 1 chars - c@ |
\ r/o 4 chars + over - dup >r swap move r> ; |
\ r/o 4 chars + over - dup >r swap move r> ; |
|
|
: bin 1+ ; |
: bin 1 or ; |
|
|
create nl$ 1 c, A c, 0 c, \ gnu includes usually a cr in dos |
create nl$ 1 c, A c, 0 c, \ gnu includes usually a cr in dos |
\ or not unix environments if |
\ or not unix environments if |
Line 1201 create nl$ 1 c, A c, 0 c, \ gnu includes
|
Line 1215 create nl$ 1 c, A c, 0 c, \ gnu includes
|
|
|
create pathfilenamebuf 256 chars allot \ !! make this grow on demand |
create pathfilenamebuf 256 chars allot \ !! make this grow on demand |
|
|
|
\ : check-file-prefix ( addr len -- addr' len' flag ) |
|
\ dup 0= IF true EXIT THEN |
|
\ over c@ '/ = IF true EXIT THEN |
|
\ over 2 S" ./" compare 0= IF true EXIT THEN |
|
\ over 3 S" ../" compare 0= IF true EXIT THEN |
|
\ over 2 S" ~/" compare 0= |
|
\ IF 1 /string |
|
\ S" HOME" getenv tuck pathfilenamebuf swap move |
|
\ 2dup + >r pathfilenamebuf + swap move |
|
\ pathfilenamebuf r> true |
|
\ ELSE false |
|
\ THEN ; |
|
|
: open-path-file ( c-addr1 u1 -- file-id c-addr2 u2 ) |
: open-path-file ( c-addr1 u1 -- file-id c-addr2 u2 ) |
\ opens a file for reading, searching in the path for it; c-addr2 |
\ opens a file for reading, searching in the path for it (unless |
\ u2 is the full filename (valid until the next call); if the file |
\ the filename contains a slash); c-addr2 u2 is the full filename |
\ is not found (or in case of other errors for each try), -38 |
\ (valid until the next call); if the file is not found (or in |
\ (non-existant file) is thrown. Opening for other access modes |
\ case of other errors for each try), -38 (non-existant file) is |
\ makes little sense, as the path will usually contain dirs that |
\ thrown. Opening for other access modes makes little sense, as |
\ are only readable for the user |
\ the path will usually contain dirs that are only readable for |
\ !! check for "/", "./", "../" in original filename; check for "~/"? |
\ the user |
|
\ !! use file-status to determine access mode? |
|
2dup [char] / scan nip ( 0<> ) |
|
if \ the filename contains a slash |
|
2dup r/o open-file throw ( c-addr1 u1 file-id ) |
|
-rot >r pathfilenamebuf r@ cmove ( file-id R: u1 ) |
|
pathfilenamebuf r> EXIT |
|
then |
pathdirs 2@ 0 |
pathdirs 2@ 0 |
|
\ check-file-prefix 0= |
|
\ IF pathdirs 2@ 0 |
?DO ( c-addr1 u1 dirnamep ) |
?DO ( c-addr1 u1 dirnamep ) |
dup >r 2@ dup >r pathfilenamebuf swap cmove ( addr u ) |
dup >r 2@ dup >r pathfilenamebuf swap cmove ( addr u ) |
2dup pathfilenamebuf r@ chars + swap cmove ( addr u ) |
2dup pathfilenamebuf r@ chars + swap cmove ( addr u ) |
pathfilenamebuf over r> + dup >r r/o open-file 0= |
pathfilenamebuf over r> + dup >r r/o open-file 0= |
if ( addr u file-id ) |
IF ( addr u file-id ) |
nip nip r> rdrop 0 leave |
nip nip r> rdrop 0 LEAVE |
then |
THEN |
rdrop drop r> cell+ cell+ |
rdrop drop r> cell+ cell+ |
LOOP |
LOOP |
|
\ ELSE 2dup open-file throw -rot THEN |
0<> -&38 and throw ( file-id u2 ) |
0<> -&38 and throw ( file-id u2 ) |
pathfilenamebuf swap ; |
pathfilenamebuf swap ; |
|
|
Line 1464 Variable argc
|
Line 1501 Variable argc
|
r> >tib +! 2 EXIT THEN |
r> >tib +! 2 EXIT THEN |
." Unknown option: " type cr 2drop 1 ; |
." Unknown option: " type cr 2drop 1 ; |
|
|
: process-args ( -- ) >tib @ >r |
: process-args ( -- ) |
|
>tib @ >r |
|
true to script? |
argc @ 1 |
argc @ 1 |
?DO |
?DO |
I arg over c@ [char] - <> |
I arg over c@ [char] - <> |
IF |
IF |
true to script? included false to script? 1 |
required 1 |
ELSE |
ELSE |
I 1+ arg do-option |
I 1+ arg do-option |
THEN |
THEN |
+LOOP |
+LOOP |
|
false to script? |
r> >tib ! ; |
r> >tib ! ; |
|
|
Defer 'cold ' noop IS 'cold |
Defer 'cold ' noop IS 'cold |
Line 1490 Defer 'cold ' noop IS 'cold
|
Line 1530 Defer 'cold ' noop IS 'cold
|
THEN |
THEN |
THEN |
THEN |
cr |
cr |
." GNU Forth 0.0alpha, Copyright (C) 1994 Free Software Foundation, Inc." cr |
." GNU Forth " version-string type ." , Copyright (C) 1994 Free Software Foundation, Inc." cr |
." GNU Forth comes with ABSOLUTELY NO WARRANTY; for details type `license'" cr |
." GNU Forth comes with ABSOLUTELY NO WARRANTY; for details type `license'" cr |
." Type `bye' to exit" |
." Type `bye' to exit" |
loadline off quit ; |
loadline off quit ; |