version 1.11, 1994/07/13 19:21:03
|
version 1.15, 1994/08/25 15:25:28
|
Line 142 Defer source
|
Line 142 Defer source
|
dup count chars bounds |
dup count chars bounds |
?DO I c@ toupper I c! 1 chars +LOOP ; |
?DO I c@ toupper I c! 1 chars +LOOP ; |
: (name) ( -- addr ) bl word ; |
: (name) ( -- addr ) bl word ; |
: (cname) ( -- addr ) bl word capitalize ; |
: sname ( -- c-addr count ) |
|
source 2dup >r >r >in @ /string (parse-white) |
|
2dup + r> - 1+ r> min >in ! ; |
|
\ name count ; |
|
|
\ Literal 17dec92py |
\ Literal 17dec92py |
|
|
Line 194 Create bases 10 , 2 , A , 100 ,
|
Line 197 Create bases 10 , 2 , A , 100 ,
|
\ !! this saving and restoring base is an abomination! - anton |
\ !! this saving and restoring base is an abomination! - anton |
: getbase ( addr u -- addr' u' ) over c@ [char] $ - dup 4 u< |
: getbase ( addr u -- addr' u' ) over c@ [char] $ - dup 4 u< |
IF cells bases + @ base ! 1 /string ELSE drop THEN ; |
IF cells bases + @ base ! 1 /string ELSE drop THEN ; |
: number? ( string -- string 0 / n -1 ) base @ >r |
: s>number ( addr len -- d ) base @ >r dpl on |
dup count over c@ [char] - = dup >r IF 1 /string THEN |
over c@ '- = dup >r IF 1 /string THEN |
getbase dpl on 0 0 2swap |
getbase dpl on 0 0 2swap |
BEGIN dup >r >number dup WHILE dup r> - WHILE |
BEGIN dup >r >number dup WHILE dup r> - WHILE |
dup dpl ! over c@ [char] . = WHILE |
dup dpl ! over c@ [char] . = WHILE |
1 /string |
1 /string |
REPEAT THEN 2drop 2drop rdrop false r> base ! EXIT THEN |
REPEAT THEN 2drop rdrop dpl off ELSE |
2drop rot drop rdrop r> IF dnegate THEN |
2drop rdrop r> IF dnegate THEN |
dpl @ dup 0< IF nip THEN r> base ! ; |
THEN r> base ! ; |
|
: snumber? ( c-addr u -- 0 / n -1 / d 0> ) |
|
s>number dpl @ 0= |
|
IF |
|
2drop false EXIT |
|
THEN |
|
dpl @ dup 0> 0= IF |
|
nip |
|
THEN ; |
|
: number? ( string -- string 0 / n -1 / d 0> ) |
|
dup >r count snumber? dup if |
|
rdrop |
|
else |
|
r> swap |
|
then ; |
: s>d ( n -- d ) dup 0< ; |
: s>d ( n -- d ) dup 0< ; |
: number ( string -- d ) |
: number ( string -- d ) |
number? ?dup 0= abort" ?" 0< IF s>d THEN ; |
number? ?dup 0= abort" ?" 0< IF s>d THEN ; |
Line 301 hex
|
Line 318 hex
|
|
|
Defer parser |
Defer parser |
Defer name ' (name) IS name |
Defer name ' (name) IS name |
Defer notfound |
Defer notfound ( c-addr count -- ) |
|
|
: no.extensions ( string -- ) IF &-13 bounce THEN ; |
: no.extensions ( addr u -- ) 2drop -&13 bounce ; |
|
|
' no.extensions IS notfound |
' no.extensions IS notfound |
|
|
: interpret |
: interpret |
BEGIN ?stack name dup c@ WHILE parser REPEAT drop ; |
BEGIN |
|
?stack sname dup |
\ interpreter compiler 30apr92py |
WHILE |
|
parser |
: interpreter ( name -- ) find ?dup |
REPEAT |
IF 1 and IF execute EXIT THEN -&14 throw THEN |
2drop ; |
number? 0= IF notfound THEN ; |
|
|
\ sinterpreter scompiler 30apr92py |
|
|
|
: sinterpreter ( c-addr u -- ) |
|
\ interpretation semantics for the name/number c-addr u |
|
2dup sfind dup |
|
IF |
|
1 and |
|
IF \ not restricted to compile state? |
|
nip nip execute EXIT |
|
THEN |
|
-&14 throw |
|
THEN |
|
drop |
|
2dup 2>r snumber? |
|
IF |
|
2rdrop |
|
ELSE |
|
2r> notfound |
|
THEN ; |
|
|
' interpreter IS parser |
' sinterpreter IS parser |
|
|
: compiler ( name -- ) find ?dup |
: scompiler ( c-addr u -- ) |
IF 0> IF execute EXIT THEN compile, EXIT THEN number? dup |
\ compilation semantics for the name/number c-addr u |
IF 0> IF swap postpone Literal THEN postpone Literal |
2dup sfind dup |
ELSE drop notfound THEN ; |
IF |
|
0> |
|
IF |
|
nip nip execute EXIT |
|
THEN |
|
compile, 2drop EXIT |
|
THEN |
|
drop |
|
2dup snumber? dup |
|
IF |
|
0> |
|
IF |
|
swap postpone Literal |
|
THEN |
|
postpone Literal |
|
2drop |
|
ELSE |
|
drop notfound |
|
THEN ; |
|
|
: [ ['] interpreter IS parser state off ; immediate |
: [ ['] sinterpreter IS parser state off ; immediate |
: ] ['] compiler IS parser state on ; |
: ] ['] scompiler IS parser state on ; |
|
|
\ locals stuff needed for control structures |
\ locals stuff needed for control structures |
|
|
Line 486 variable dead-code \ true if normal code
|
Line 540 variable dead-code \ true if normal code
|
\ This is the preferred alternative to the idiom "?DUP IF", since it can be |
\ This is the preferred alternative to the idiom "?DUP IF", since it can be |
\ better handled by tools like stack checkers |
\ better handled by tools like stack checkers |
POSTPONE ?dup POSTPONE if ; immediate restrict |
POSTPONE ?dup POSTPONE if ; immediate restrict |
: ?DUP-NOT-IF \ general |
: ?DUP-0=-IF \ general |
POSTPONE ?dup POSTPONE 0= POSTPONE if ; immediate restrict |
POSTPONE ?dup POSTPONE 0= POSTPONE if ; immediate restrict |
|
|
: THEN ( orig -- ) |
: THEN ( orig -- ) |
Line 730 defer header
|
Line 784 defer header
|
|
|
: name, ( "name" -- ) |
: name, ( "name" -- ) |
name c@ |
name c@ |
dup $1F u> &-19 and throw ( is name too long? ) |
dup $1F u> -&19 and throw ( is name too long? ) |
1+ chars allot align ; |
1+ chars allot align ; |
: input-stream-header ( "name" -- ) |
: input-stream-header ( "name" -- ) |
\ !! this is f83-implementation-dependent |
\ !! this is f83-implementation-dependent |
Line 756 create nextname-buffer 32 chars allot
|
Line 810 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? ) |
dup $1F u> -&19 and throw ( is 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 836 Create ??? 0 , 3 c, char ? c, char ? c,
|
Line 890 Create ??? 0 , 3 c, char ? c, char ? c,
|
|
|
\ IS Defer What's Defers TO 24feb93py |
\ IS Defer What's Defers TO 24feb93py |
|
|
: Defer |
: Defer ( -- ) |
Create ( -- ) |
\ !! shouldn't it be initialized with abort or something similar? |
['] noop A, |
Header Reveal [ :dodefer ] Literal cfa, |
DOES> ( ??? ) |
['] noop A, ; |
@ execute ; |
\ Create ( -- ) |
|
\ ['] noop A, |
|
\ DOES> ( ??? ) |
|
\ @ execute ; |
|
|
: IS ( addr "name" -- ) |
: IS ( addr "name" -- ) |
' >body |
' >body |
Line 854 Create ??? 0 , 3 c, char ? c, char ? c,
|
Line 911 Create ??? 0 , 3 c, char ? c, char ? c,
|
state @ IF postpone ALiteral postpone @ ELSE @ THEN ; |
state @ IF postpone ALiteral postpone @ ELSE @ THEN ; |
immediate |
immediate |
: Defers ( "name" -- ) ' >body @ compile, ; |
: Defers ( "name" -- ) ' >body @ compile, ; |
immediate restrict |
immediate |
|
|
\ : ; 24feb93py |
\ : ; 24feb93py |
|
|
Line 903 AVariable current
|
Line 960 AVariable current
|
\ end-struct wordlist-struct |
\ end-struct wordlist-struct |
|
|
: f83find ( addr len wordlist -- nfa / false ) @ (f83find) ; |
: f83find ( addr len wordlist -- nfa / false ) @ (f83find) ; |
: f83casefind ( addr len wordlist -- nfa / false ) @ (f83casefind) ; |
|
|
|
\ Search list table: find reveal |
\ Search list table: find reveal |
Create f83search ' f83casefind A, ' (reveal) A, ' drop A, |
Create f83search ' f83find A, ' (reveal) A, ' drop A, |
|
|
: caps-name ['] (cname) IS name ['] f83find f83search ! ; |
|
: case-name ['] (name) IS name ['] f83casefind f83search ! ; |
|
: case-sensitive ['] (name) IS name ['] f83find f83search ! ; |
|
|
|
Create forth-wordlist NIL A, G f83search T A, NIL A, NIL A, |
Create forth-wordlist NIL A, G f83search T A, NIL A, NIL A, |
AVariable search G forth-wordlist search T ! |
AVariable search G forth-wordlist search T ! |
Line 938 Variable warnings G -1 warnings T !
|
Line 990 Variable warnings G -1 warnings T !
|
then |
then |
2drop 2drop ; |
2drop 2drop ; |
|
|
: find ( addr -- cfa +-1 / string false ) dup |
: sfind ( c-addr u -- xt n / 0 ) |
count search @ search-wordlist dup IF rot drop THEN ; |
search @ search-wordlist ; |
|
|
|
: find ( addr -- cfa +-1 / string false ) |
|
\ !! not ANS conformant: returns +-2 for restricted words |
|
dup count sfind dup if |
|
rot drop |
|
then ; |
|
|
: reveal ( -- ) |
: reveal ( -- ) |
last? if |
last? if |
Line 949 Variable warnings G -1 warnings T !
|
Line 1007 Variable warnings G -1 warnings T !
|
|
|
: rehash ( wid -- ) dup cell+ @ cell+ cell+ @ execute ; |
: rehash ( wid -- ) dup cell+ @ cell+ cell+ @ execute ; |
|
|
: ' ( "name" -- addr ) name find 0= no.extensions ; |
: ' ( "name" -- addr ) name find 0= if drop -&13 bounce then ; |
: ['] ( "name" -- addr ) ' postpone ALiteral ; immediate |
: ['] ( "name" -- addr ) ' postpone ALiteral ; immediate |
\ Input 13feb93py |
\ Input 13feb93py |
|
|
Line 1024 DEFER Emit
|
Line 1082 DEFER Emit
|
: refill ( -- flag ) |
: refill ( -- flag ) |
tib /line |
tib /line |
loadfile @ ?dup |
loadfile @ ?dup |
IF dup file-position throw linestart 2! |
IF \ dup file-position throw linestart 2! |
read-line throw |
read-line throw |
ELSE linestart @ IF 2drop false EXIT THEN |
ELSE loadline @ 0< IF 2drop false EXIT THEN |
accept true |
accept true |
THEN |
THEN |
1 loadline +! |
1 loadline +! |
Line 1060 create nl$ 1 c, A c, 0 c, \ gnu includes
|
Line 1118 create nl$ 1 c, A c, 0 c, \ gnu includes
|
|
|
\ include-file 07apr93py |
\ include-file 07apr93py |
|
|
: include-file ( i*x fid -- j*x ) |
: push-file ( -- ) r> |
linestart @ >r loadline @ >r loadfile @ >r |
( linestart 2@ >r >r ) loadline @ >r loadfile @ >r |
blk @ >r >tib @ >r #tib @ dup >r >in @ >r |
blk @ >r >tib @ >r #tib @ dup >r >tib +! >in @ >r >r ; |
|
|
|
: pop-file ( -- ) r> |
|
r> >in ! r> #tib ! r> >tib ! r> blk ! |
|
r> loadfile ! r> loadline ! ( r> r> linestart 2! ) >r ; |
|
|
>tib +! loadfile ! |
: include-file ( i*x fid -- j*x ) |
|
push-file loadfile ! |
0 loadline ! blk off |
0 loadline ! blk off |
BEGIN refill WHILE interpret REPEAT |
BEGIN refill WHILE interpret REPEAT |
loadfile @ close-file throw |
loadfile @ close-file throw |
|
pop-file ; |
r> >in ! r> #tib ! r> >tib ! r> blk ! |
|
r> loadfile ! r> loadline ! r> linestart ! ; |
|
|
|
: included ( i*x addr u -- j*x ) |
: included ( i*x addr u -- j*x ) |
loadfilename 2@ >r >r |
loadfilename 2@ >r >r |
Line 1104 create nl$ 1 c, A c, 0 c, \ gnu includes
|
Line 1165 create nl$ 1 c, A c, 0 c, \ gnu includes
|
|
|
\ */MOD */ 17may93jaw |
\ */MOD */ 17may93jaw |
|
|
|
\ !! I think */mod should have the same rounding behaviour as / - anton |
: */mod >r m* r> sm/rem ; |
: */mod >r m* r> sm/rem ; |
|
|
: */ */mod nip ; |
: */ */mod nip ; |
Line 1111 create nl$ 1 c, A c, 0 c, \ gnu includes
|
Line 1173 create nl$ 1 c, A c, 0 c, \ gnu includes
|
\ EVALUATE 17may93jaw |
\ EVALUATE 17may93jaw |
|
|
: evaluate ( c-addr len -- ) |
: evaluate ( c-addr len -- ) |
linestart @ >r loadline @ >r loadfile @ >r |
push-file dup #tib ! >tib @ swap move |
blk @ >r >tib @ >r #tib @ dup >r >in @ >r |
>in off blk off loadfile off -1 loadline ! |
|
|
>tib +! dup #tib ! >tib @ swap move |
|
>in off blk off loadfile off -1 linestart ! |
|
|
|
BEGIN interpret >in @ #tib @ u>= UNTIL |
BEGIN interpret >in @ #tib @ u>= UNTIL |
|
|
r> >in ! r> #tib ! r> >tib ! r> blk ! |
pop-file ; |
r> loadfile ! r> loadline ! r> linestart ! ; |
|
|
|
|
|
: abort -1 throw ; |
: abort -1 throw ; |
Line 1205 Variable env
|
Line 1263 Variable env
|
Variable argv |
Variable argv |
Variable argc |
Variable argc |
|
|
: get-args ( -- ) #tib off |
0 Value script? ( -- flag ) |
argc @ 1 ?DO I arg 2dup source + swap move |
|
#tib +! drop bl source + c! 1 #tib +! LOOP |
|
>in off #tib @ 0<> #tib +! ; |
|
|
|
: script? ( -- flag ) 0 arg 1 arg dup 3 pick - /string compare 0= ; |
: ">tib ( addr len -- ) dup #tib ! >in off tib swap move ; |
|
|
|
: do-option ( addr1 len1 addr2 len2 -- n ) 2swap |
|
2dup s" -e" compare 0= >r |
|
2dup s" -evaluate" compare 0= r> or |
|
IF 2drop ">tib interpret 2 EXIT THEN |
|
." Unknown option: " type cr 2drop 1 ; |
|
|
|
: process-args ( -- ) argc @ 1 |
|
?DO I arg over c@ [char] - <> |
|
IF true to script? included false to script? 1 |
|
ELSE I 1+ arg do-option |
|
THEN |
|
+LOOP ; |
|
|
: cold ( -- ) |
: cold ( -- ) |
argc @ 1 > |
argc @ 1 > |
IF script? |
IF |
IF |
['] process-args catch ?dup |
1 arg ['] included |
|
ELSE |
|
get-args ['] interpret |
|
THEN |
|
catch ?dup |
|
IF |
IF |
dup >r DoError cr r> (bye) |
dup >r DoError cr r> negate (bye) |
THEN |
THEN |
THEN |
THEN |
cr ." GNU Forth 0.0alpha, Copyright (C) 1994 Free Software Foundation" |
cr |
cr ." GNU Forth comes with ABSOLUTELY NO WARRANTY; for details type `license'" |
." GNU Forth 0.0alpha, Copyright (C) 1994 Free Software Foundation, Inc." cr |
cr quit ; |
." GNU Forth comes with ABSOLUTELY NO WARRANTY; for details type `license'" cr |
|
." Type `bye' to exit" |
|
quit ; |
|
|
|
: license ( -- ) cr |
|
." This program is free software; you can redistribute it and/or modify" cr |
|
." it under the terms of the GNU General Public License as published by" cr |
|
." the Free Software Foundation; either version 2 of the License, or" cr |
|
." (at your option) any later version." cr cr |
|
|
|
." This program is distributed in the hope that it will be useful," cr |
|
." but WITHOUT ANY WARRANTY; without even the implied warranty of" cr |
|
." MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the" cr |
|
." GNU General Public License for more details." cr cr |
|
|
|
." You should have received a copy of the GNU General Public License" cr |
|
." along with this program; if not, write to the Free Software" cr |
|
." Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA." cr ; |
|
|
: boot ( **env **argv argc -- ) |
: boot ( **env **argv argc -- ) |
argc ! argv ! env ! main-task up! |
argc ! argv ! env ! main-task up! |
sp@ dup s0 ! $10 + >tib ! rp@ r0 ! fp@ f0 ! cold ; |
sp@ dup s0 ! $10 + >tib ! rp@ r0 ! fp@ f0 ! cold ; |
|
|
: bye cr 0 (bye) ; |
: bye script? 0= IF cr THEN 0 (bye) ; |
|
|
\ **argv may be scanned by the C starter to get some important |
\ **argv may be scanned by the C starter to get some important |
\ information, as -display and -geometry for an X client FORTH |
\ information, as -display and -geometry for an X client FORTH |