version 1.10, 1994/07/08 15:00:51
|
version 1.12, 1994/07/21 10:52:44
|
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 ; |
\ : (cname) ( -- addr ) bl word capitalize ; |
|
|
\ Literal 17dec92py |
\ Literal 17dec92py |
|
|
Line 194 Create bases 10 , 2 , A , 100 ,
|
Line 194 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 ! ; |
|
: number? ( string -- string 0 / n -1 / d 0> ) |
|
dup count s>number dpl @ 0= IF 2drop false EXIT THEN |
|
rot drop dpl @ dup 0> 0= IF nip 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 303 Defer parser
|
Line 306 Defer parser
|
Defer name ' (name) IS name |
Defer name ' (name) IS name |
Defer notfound |
Defer notfound |
|
|
: no.extensions ( string -- ) IF &-13 bounce THEN ; |
: no.extensions ( string -- ) IF -&13 bounce THEN ; |
|
|
' no.extensions IS notfound |
' no.extensions IS notfound |
|
|
Line 385 variable dead-code \ true if normal code
|
Line 388 variable dead-code \ true if normal code
|
over 0<> |
over 0<> |
while |
while |
over |
over |
cell+ name> >body @ max |
name> >body @ max |
swap @ swap ( get next ) |
swap @ swap ( get next ) |
repeat |
repeat |
faligned nip ; |
faligned nip ; |
Line 730 defer header
|
Line 733 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 759 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 854 Create ??? 0 , 3 c, char ? c, char ? c,
|
Line 857 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 906 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 1024 DEFER Emit
|
Line 1022 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 1058 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 ; |
|
|
>tib +! loadfile ! |
: pop-file ( -- ) r> |
|
r> >in ! r> #tib ! r> >tib ! r> blk ! |
|
r> loadfile ! r> loadline ! ( r> r> linestart 2! ) >r ; |
|
|
|
: 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 1111 create nl$ 1 c, A c, 0 c, \ gnu includes
|
Line 1112 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 1202 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 |
: ">tib ( addr len -- ) dup #tib ! >in off tib swap move ; |
>in off #tib @ 0<> #tib +! ; |
|
|
|
: script? ( -- flag ) 0 arg 1 arg dup 3 pick - /string compare 0= ; |
: 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" |
." 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 comes with ABSOLUTELY NO WARRANTY; for details type `license'" |
cr quit ; |
cr 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 1, or (at your option)" cr |
|
." 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 |