version 1.29, 1995/02/09 17:49:57
|
version 1.41, 1995/10/07 17:38:16
|
Line 31
|
Line 31
|
|
|
HEX |
HEX |
|
|
|
\ labels for some code addresses |
|
|
|
: docon: ( -- addr ) \ gforth |
|
\ the code address of a @code{CONSTANT} |
|
['] bl >code-address ; |
|
|
|
: docol: ( -- addr ) \ gforth |
|
\ the code address of a colon definition |
|
['] docon: >code-address ; |
|
|
|
: dovar: ( -- addr ) \ gforth |
|
\ the code address of a @code{CREATE}d word |
|
['] udp >code-address ; |
|
|
|
: douser: ( -- addr ) \ gforth |
|
\ the code address of a @code{USER} variable |
|
['] s0 >code-address ; |
|
|
|
: dodefer: ( -- addr ) \ gforth |
|
\ the code address of a @code{defer}ed word |
|
['] source >code-address ; |
|
|
|
: dofield: ( -- addr ) \ gforth |
|
\ the code address of a @code{field} |
|
['] reveal-method >code-address ; |
|
|
\ Bit string manipulation 06oct92py |
\ Bit string manipulation 06oct92py |
|
|
Create bits 80 c, 40 c, 20 c, 10 c, 8 c, 4 c, 2 c, 1 c, |
Create bits 80 c, 40 c, 20 c, 10 c, 8 c, 4 c, 2 c, 1 c, |
Line 115 DOES> ( n -- ) + c@ ;
|
Line 141 DOES> ( n -- ) + c@ ;
|
\ input stream primitives 23feb93py |
\ input stream primitives 23feb93py |
|
|
: tib >tib @ ; |
: tib >tib @ ; |
Defer source |
Defer source \ used by dodefer:, must be defer |
: (source) ( -- addr count ) tib #tib @ ; |
: (source) ( -- addr count ) tib #tib @ ; |
' (source) IS source |
' (source) IS source |
|
|
Line 153 Defer source
|
Line 179 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 199 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 340 hex
|
Line 372 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 728 Avariable leave-sp leave-stack 3 cells
|
Line 762 Avariable leave-sp leave-stack 3 cells
|
POSTPONE begin drop do-dest |
POSTPONE begin drop do-dest |
( 0 0 0 >leave ) ; immediate restrict |
( 0 0 0 >leave ) ; immediate restrict |
|
|
: ?DO ( -- do-sys ) |
: ?do-like ( -- do-sys ) |
( 0 0 0 >leave ) |
( 0 0 0 >leave ) |
POSTPONE (?do) |
|
>mark >leave |
>mark >leave |
POSTPONE begin drop do-dest ; immediate restrict |
POSTPONE begin drop do-dest ; |
|
|
|
: ?DO ( -- do-sys ) \ core-ext question-do |
|
POSTPONE (?do) ?do-like ; immediate restrict |
|
|
|
: +DO ( -- do-sys ) \ gforth plus-do |
|
POSTPONE (+do) ?do-like ; immediate restrict |
|
|
|
: U+DO ( -- do-sys ) \ gforth u-plus-do |
|
POSTPONE (u+do) ?do-like ; immediate restrict |
|
|
|
: -DO ( -- do-sys ) \ gforth minus-do |
|
POSTPONE (-do) ?do-like ; immediate restrict |
|
|
|
: U-DO ( -- do-sys ) \ gforth u-minus-do |
|
POSTPONE (u-do) ?do-like ; immediate restrict |
|
|
: FOR ( -- do-sys ) |
: FOR ( -- do-sys ) |
POSTPONE (for) |
POSTPONE (for) |
Line 745 Avariable leave-sp leave-stack 3 cells
|
Line 793 Avariable leave-sp leave-stack 3 cells
|
>r >r 0 cs-pick swap cell - swap 1 cs-roll r> r> rot do-dest? |
>r >r 0 cs-pick swap cell - swap 1 cs-roll r> r> rot do-dest? |
until-like POSTPONE done POSTPONE unloop ; |
until-like POSTPONE done POSTPONE unloop ; |
|
|
: LOOP ( do-sys -- ) |
: LOOP ( do-sys -- ) \ core |
['] (loop) ['] (loop)-lp+!# loop-like ; immediate restrict |
['] (loop) ['] (loop)-lp+!# loop-like ; immediate restrict |
|
|
: +LOOP ( do-sys -- ) |
: +LOOP ( do-sys -- ) \ core plus-loop |
['] (+loop) ['] (+loop)-lp+!# loop-like ; immediate restrict |
['] (+loop) ['] (+loop)-lp+!# loop-like ; immediate restrict |
|
|
|
\ !! should the compiler warn about +DO..-LOOP? |
|
: -LOOP ( do-sys -- ) \ gforth minus-loop |
|
['] (-loop) ['] (-loop)-lp+!# loop-like ; immediate restrict |
|
|
\ A symmetric version of "+LOOP". I.e., "-high -low ?DO -inc S+LOOP" |
\ A symmetric version of "+LOOP". I.e., "-high -low ?DO -inc S+LOOP" |
\ will iterate as often as "high low ?DO inc S+LOOP". For positive |
\ will iterate as often as "high low ?DO inc S+LOOP". For positive |
\ increments it behaves like "+LOOP". Use S+LOOP instead of +LOOP for |
\ increments it behaves like "+LOOP". Use S+LOOP instead of +LOOP for |
\ negative increments. |
\ negative increments. |
: S+LOOP ( do-sys -- ) |
: S+LOOP ( do-sys -- ) \ gforth s-plus-loop |
['] (s+loop) ['] (s+loop)-lp+!# loop-like ; immediate restrict |
['] (s+loop) ['] (s+loop)-lp+!# loop-like ; immediate restrict |
|
|
: NEXT ( do-sys -- ) |
: NEXT ( do-sys -- ) |
Line 781 Avariable leave-sp leave-stack 3 cells
|
Line 833 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 |
: ( [char] ) parse 2drop ; immediate |
: ( [char] ) parse 2drop ; immediate |
: \ blk @ IF >in @ c/l / 1+ c/l * >in ! EXIT THEN |
: \ ( -- ) \ core-ext backslash |
source >in ! drop ; immediate |
blk @ |
|
IF |
|
>in @ c/l / 1+ c/l * >in ! |
|
EXIT |
|
THEN |
|
source >in ! drop ; immediate |
|
|
|
: \G ( -- ) \ new backslash |
|
POSTPONE \ ; immediate |
|
|
\ error handling 22feb93py |
\ error handling 22feb93py |
\ 'abort thrown out! 11may93jaw |
\ 'abort thrown out! 11may93jaw |
Line 819 defer header ' (header) IS header
|
Line 888 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 846 create nextname-buffer 32 chars allot
|
Line 914 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 878 Create ??? 0 , 3 c, char ? c, char ? c,
|
Line 946 Create ??? 0 , 3 c, char ? c, char ? c,
|
cell +loop |
cell +loop |
drop ??? ( wouldn't 0 be better? ) ; |
drop ??? ( wouldn't 0 be better? ) ; |
|
|
\ indirect threading 17mar93py |
\ threading 17mar93py |
|
|
: cfa, ( code-address -- ) |
: cfa, ( code-address -- ) \ gforth |
here lastcfa ! |
here |
here 0 A, 0 , code-address! ; |
dup lastcfa ! |
: compile, ( xt -- ) A, ; |
0 A, 0 , code-address! ; |
: !does ( addr -- ) lastcfa @ does-code! ; |
: compile, ( xt -- ) \ core-ext |
: (;code) ( R: addr -- ) r> /does-handler + !does ; |
A, ; |
|
: !does ( addr -- ) lastxt does-code! ; |
|
: (does>) ( R: addr -- ) r> /does-handler + !does ; |
: dodoes, ( -- ) |
: dodoes, ( -- ) |
here /does-handler allot does-handler! ; |
here /does-handler allot does-handler! ; |
|
|
\ direct threading is implementation dependent |
: Create Header reveal dovar: cfa, ; |
|
|
: Create Header reveal [ :dovar ] Literal cfa, ; |
|
|
|
\ DOES> 17mar93py |
\ DOES> 17mar93py |
|
|
: DOES> ( compilation: -- ) |
: DOES> ( compilation: -- ) \ core |
state @ |
state @ |
IF |
IF |
;-hook postpone (;code) dodoes, |
;-hook postpone (does>) ?struc dodoes, |
ELSE |
ELSE |
dodoes, here !does 0 ] |
align dodoes, here !does ] |
THEN |
THEN |
:-hook ; immediate |
defstart :-hook ; immediate |
|
|
\ Create Variable User Constant 17mar93py |
\ Create Variable User Constant 17mar93py |
|
|
Line 914 Create ??? 0 , 3 c, char ? c, char ? c,
|
Line 982 Create ??? 0 , 3 c, char ? c, char ? c,
|
: User Variable ; |
: User Variable ; |
: AUser AVariable ; |
: AUser AVariable ; |
|
|
: (Constant) Header reveal [ :docon ] Literal cfa, ; |
: (Constant) Header reveal docon: cfa, ; |
: Constant (Constant) , ; |
: Constant (Constant) , ; |
: AConstant (Constant) A, ; |
: AConstant (Constant) A, ; |
|
|
: 2CONSTANT |
: 2Constant |
create ( w1 w2 "name" -- ) |
Create ( w1 w2 "name" -- ) |
2, |
2, |
does> ( -- w1 w2 ) |
DOES> ( -- w1 w2 ) |
2@ ; |
2@ ; |
|
|
\ IS Defer What's Defers TO 24feb93py |
\ IS Defer What's Defers TO 24feb93py |
|
|
: Defer ( -- ) |
: Defer ( -- ) |
\ !! shouldn't it be initialized with abort or something similar? |
\ !! shouldn't it be initialized with abort or something similar? |
Header Reveal [ :dodefer ] Literal cfa, |
Header Reveal dodefer: cfa, |
['] noop A, ; |
['] noop A, ; |
\ Create ( -- ) |
\ Create ( -- ) |
\ ['] noop A, |
\ ['] noop A, |
Line 954 Create ??? 0 , 3 c, char ? c, char ? c,
|
Line 1022 Create ??? 0 , 3 c, char ? c, char ? c,
|
defer :-hook ( sys1 -- sys2 ) |
defer :-hook ( sys1 -- sys2 ) |
defer ;-hook ( sys2 -- sys1 ) |
defer ;-hook ( sys2 -- sys1 ) |
|
|
: : ( -- colon-sys ) Header [ :docol ] Literal cfa, defstart ] :-hook ; |
: : ( -- colon-sys ) Header docol: cfa, defstart ] :-hook ; |
: ; ( colon-sys -- ) ;-hook ?struc postpone exit reveal postpone [ ; |
: ; ( colon-sys -- ) ;-hook ?struc postpone exit reveal postpone [ ; |
immediate restrict |
immediate restrict |
|
|
: :noname ( -- xt colon-sys ) |
: :noname ( -- xt colon-sys ) |
0 last ! |
0 last ! |
here [ :docol ] Literal cfa, 0 ] :-hook ; |
here docol: cfa, 0 ] :-hook ; |
|
|
\ Search list handling 23feb93py |
\ Search list handling 23feb93py |
|
|
Line 968 AVariable current
|
Line 1036 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 |
|
|
\ word list structure: |
\ word list structure: |
\ struct |
|
\ 1 cells: field find-method \ xt: ( c_addr u wid -- name-id ) |
struct |
\ 1 cells: field reveal-method \ xt: ( -- ) |
1 cells: field find-method \ xt: ( c_addr u wid -- name-id ) |
\ 1 cells: field rehash-method \ xt: ( wid -- ) |
1 cells: field reveal-method \ xt: ( -- ) \ used by dofield:, must be field |
|
1 cells: field rehash-method \ xt: ( wid -- ) |
\ \ !! what else |
\ \ !! what else |
\ end-struct wordlist-map-struct |
end-struct wordlist-map-struct |
|
|
\ struct |
struct |
\ 1 cells: field wordlist-id \ not the same as wid; representation depends on implementation |
1 cells: field wordlist-id \ not the same as wid; representation depends on implementation |
\ 1 cells: field wordlist-map \ pointer to a wordlist-map-struct |
1 cells: field wordlist-map \ pointer to a wordlist-map-struct |
\ 1 cells: field wordlist-link \ link field to other wordlists |
1 cells: field wordlist-link \ link field to other wordlists |
\ 1 cells: field wordlist-extend \ points to wordlist extensions (eg hash) |
1 cells: field wordlist-extend \ points to wordlist extensions (eg hash) |
\ end-struct wordlist-struct |
end-struct wordlist-struct |
|
|
: f83find ( addr len wordlist -- nfa / false ) @ (f83find) ; |
: f83find ( addr len wordlist -- nfa / false ) @ (f83find) ; |
|
|
Line 1005 AVariable lookup G forth-wordlist
|
Line 1074 AVariable lookup G forth-wordlist
|
G forth-wordlist current T ! |
G forth-wordlist current T ! |
|
|
: (search-wordlist) ( addr count wid -- nfa / false ) |
: (search-wordlist) ( addr count wid -- nfa / false ) |
dup cell+ @ @ execute ; |
dup wordlist-map @ find-method @ execute ; |
|
|
: search-wordlist ( addr count wid -- 0 / xt +-1 ) |
: search-wordlist ( addr count wid -- 0 / xt +-1 ) |
(search-wordlist) dup IF found THEN ; |
(search-wordlist) dup IF found THEN ; |
Line 1039 Variable warnings G -1 warnings T !
|
Line 1108 Variable warnings G -1 warnings T !
|
last? if |
last? if |
name>string current @ check-shadow |
name>string current @ check-shadow |
then |
then |
current @ cell+ @ cell+ @ execute ; |
current @ wordlist-map @ reveal-method @ execute ; |
|
|
: rehash ( wid -- ) dup cell+ @ cell+ cell+ @ execute ; |
: rehash ( wid -- ) dup wordlist-map @ rehash-method @ execute ; |
|
|
: ' ( "name" -- addr ) name sfind 0= if -&13 bounce then ; |
: ' ( "name" -- addr ) name sfind 0= if -&13 bounce then ; |
: ['] ( "name" -- addr ) ' postpone ALiteral ; immediate |
: ['] ( "name" -- addr ) ' postpone ALiteral ; immediate |
Line 1073 Variable warnings G -1 warnings T !
|
Line 1142 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 1125 Defer key
|
Line 1195 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 1152 Defer key
|
Line 1222 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 1192 create nl$ 1 c, A c, 0 c, \ gnu includes
|
Line 1262 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 1288 create included-files 0 , 0 , ( pointer
|
Line 1381 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 1446 Variable argc
|
Line 1539 Variable argc
|
2drop |
2drop |
here r> tuck - 2 cells / ; |
here r> tuck - 2 cells / ; |
|
|
: do-option ( addr1 len1 addr2 len2 -- n ) 2swap |
: do-option ( addr1 len1 addr2 len2 -- n ) |
2dup s" -e" compare 0= >r |
2swap |
2dup s" -evaluate" compare 0= r> or |
2dup s" -e" compare 0= >r |
IF 2drop dup >r ['] evaluate catch |
2dup s" --evaluate" compare 0= r> or |
?dup IF dup >r DoError r> negate (bye) THEN |
IF 2drop dup >r ['] evaluate catch |
r> >tib +! 2 EXIT THEN |
?dup IF dup >r DoError r> negate (bye) THEN |
." Unknown option: " type cr 2drop 1 ; |
r> >tib +! 2 EXIT THEN |
|
." Unknown option: " type cr 2drop 1 ; |
|
|
: process-args ( -- ) >tib @ >r |
: process-args ( -- ) |
|
>tib @ >r |
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+ argc @ = IF s" " ELSE I 1+ arg THEN |
|
do-option |
THEN |
THEN |
+LOOP |
+LOOP |
r> >tib ! ; |
r> >tib ! ; |
Line 1470 Defer 'cold ' noop IS 'cold
|
Line 1566 Defer 'cold ' noop IS 'cold
|
|
|
: cold ( -- ) |
: cold ( -- ) |
pathstring 2@ process-path pathdirs 2! |
pathstring 2@ process-path pathdirs 2! |
|
0 0 included-files 2! |
'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 ; |