version 1.35, 1995/04/20 09:42:55
|
version 1.40, 1995/09/06 21:00:21
|
Line 346 hex
|
Line 346 hex
|
|
|
\ ?stack 23feb93py |
\ ?stack 23feb93py |
|
|
: ?stack ( ?? -- ?? ) sp@ s0 @ > IF -4 throw THEN ; |
: ?stack ( ?? -- ?? ) |
|
sp@ s0 @ > IF -4 throw THEN |
|
fp@ f0 @ > IF -&45 throw THEN ; |
\ ?stack should be code -- it touches an empty stack! |
\ ?stack should be code -- it touches an empty stack! |
|
|
\ interpret 10mar92py |
\ interpret 10mar92py |
Line 990 AVariable current
|
Line 992 AVariable current
|
|
|
: last? ( -- false / nfa nfa ) last @ ?dup ; |
: last? ( -- false / nfa nfa ) last @ ?dup ; |
: (reveal) ( -- ) |
: (reveal) ( -- ) |
last? |
last? |
IF |
IF |
dup @ 0< |
dup @ 0< |
IF |
IF |
current @ @ over ! current @ ! |
current @ @ over ! current @ ! |
ELSE |
ELSE |
drop |
drop |
THEN |
THEN |
THEN ; |
THEN ; |
|
|
\ object oriented search list 17mar93py |
\ object oriented search list 17mar93py |
|
|
Line 1096 Variable warnings G -1 warnings T !
|
Line 1098 Variable warnings G -1 warnings T !
|
: (ret) type-rest drop true space ; |
: (ret) type-rest drop true space ; |
: back dup IF 1- #bs emit ELSE #bell emit THEN 0 ; |
: back dup IF 1- #bs emit ELSE #bell emit THEN 0 ; |
: forw 2 pick over <> IF 2dup + c@ emit 1+ ELSE #bell emit THEN 0 ; |
: forw 2 pick over <> IF 2dup + c@ emit 1+ ELSE #bell emit THEN 0 ; |
|
: eof 2 pick 0= IF bye ELSE (ret) THEN ; |
|
|
Create ctrlkeys |
Create ctrlkeys |
] false false back false false false forw false |
] false false back false eof false forw false |
?del false (ret) false false (ret) false false |
?del false (ret) false false (ret) false false |
false false false false false false false false |
false false false false false false false false |
false false false false false false false false [ |
false false false false false false false false [ |
Line 1148 Defer key
|
Line 1151 Defer key
|
\ Query 07apr93py |
\ Query 07apr93py |
|
|
: refill ( -- flag ) |
: refill ( -- flag ) |
blk @ IF 1 blk +! true EXIT THEN |
blk @ IF 1 blk +! true 0 >in ! EXIT THEN |
tib /line |
tib /line |
loadfile @ ?dup |
loadfile @ ?dup |
IF read-line throw |
IF read-line throw |
Line 1215 create nl$ 1 c, A c, 0 c, \ gnu includes
|
Line 1218 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 1311 create included-files 0 , 0 , ( pointer
|
Line 1337 create included-files 0 , 0 , ( pointer
|
: recurse ( -- ) |
: recurse ( -- ) |
lastxt compile, ; immediate restrict |
lastxt compile, ; immediate restrict |
: recursive ( -- ) |
: recursive ( -- ) |
reveal ; immediate |
reveal last off ; immediate |
|
|
\ */MOD */ 17may93jaw |
\ */MOD */ 17may93jaw |
|
|
Line 1480 Variable argc
|
Line 1506 Variable argc
|
|
|
: process-args ( -- ) |
: process-args ( -- ) |
>tib @ >r |
>tib @ >r |
true to script? |
|
argc @ 1 |
argc @ 1 |
?DO |
?DO |
I arg over c@ [char] - <> |
I arg over c@ [char] - <> |
IF |
IF |
required 1 |
required 1 |
ELSE |
ELSE |
I 1+ arg do-option |
I 1+ argc @ = IF s" " ELSE I 1+ arg THEN |
|
do-option |
THEN |
THEN |
+LOOP |
+LOOP |
false to script? |
|
r> >tib ! ; |
r> >tib ! ; |
|
|
Defer 'cold ' noop IS 'cold |
Defer 'cold ' noop IS 'cold |
Line 1501 Defer 'cold ' noop IS 'cold
|
Line 1526 Defer 'cold ' noop IS 'cold
|
'cold |
'cold |
argc @ 1 > |
argc @ 1 > |
IF |
IF |
|
true to script? |
['] process-args catch ?dup |
['] process-args catch ?dup |
IF |
IF |
dup >r DoError cr r> negate (bye) |
dup >r DoError cr r> negate (bye) |
THEN |
THEN |
|
cr |
THEN |
THEN |
cr |
false to script? |
." 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 ; |