version 1.19, 1994/09/05 17:36:20
|
version 1.20, 1994/09/12 19:00:32
|
Line 154 Defer source
|
Line 154 Defer source
|
|
|
\ name 13feb93py |
\ name 13feb93py |
|
|
: capitalize ( addr -- addr ) |
: capitalize ( addr len -- addr len ) |
dup count chars bounds |
2dup chars 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) ( -- c-addr count ) |
: sname ( -- c-addr count ) |
|
source 2dup >r >r >in @ /string (parse-white) |
source 2dup >r >r >in @ /string (parse-white) |
2dup + r> - 1+ r> min >in ! ; |
2dup + r> - 1+ r> min >in ! ; |
\ name count ; |
\ name count ; |
Line 176 Defer source
|
Line 175 Defer source
|
|
|
: (compile) ( -- ) r> dup cell+ >r @ A, ; |
: (compile) ( -- ) r> dup cell+ >r @ A, ; |
: postpone ( "name" -- ) |
: postpone ( "name" -- ) |
name find dup 0= abort" Can't compile " |
name sfind dup 0= abort" Can't compile " |
0> IF A, ELSE postpone (compile) A, THEN ; |
0> IF A, ELSE postpone (compile) A, THEN ; |
immediate restrict |
immediate restrict |
|
|
Line 342 Defer notfound ( c-addr count -- )
|
Line 341 Defer notfound ( c-addr count -- )
|
|
|
: interpret |
: interpret |
BEGIN |
BEGIN |
?stack sname dup |
?stack name dup |
WHILE |
WHILE |
parser |
parser |
REPEAT |
REPEAT |
2drop ; |
2drop ; |
|
|
\ sinterpreter scompiler 30apr92py |
\ interpreter compiler 30apr92py |
|
|
: sinterpreter ( c-addr u -- ) |
: interpreter ( c-addr u -- ) |
\ interpretation semantics for the name/number c-addr u |
\ interpretation semantics for the name/number c-addr u |
2dup sfind dup |
2dup sfind dup |
IF |
IF |
Line 368 Defer notfound ( c-addr count -- )
|
Line 367 Defer notfound ( c-addr count -- )
|
2r> notfound |
2r> notfound |
THEN ; |
THEN ; |
|
|
' sinterpreter IS parser |
' interpreter IS parser |
|
|
: scompiler ( c-addr u -- ) |
: compiler ( c-addr u -- ) |
\ compilation semantics for the name/number c-addr u |
\ compilation semantics for the name/number c-addr u |
2dup sfind dup |
2dup sfind dup |
IF |
IF |
Line 393 Defer notfound ( c-addr count -- )
|
Line 392 Defer notfound ( c-addr count -- )
|
drop notfound |
drop notfound |
THEN ; |
THEN ; |
|
|
: [ ['] sinterpreter IS parser state off ; immediate |
: [ ['] interpreter IS parser state off ; immediate |
: ] ['] scompiler IS parser state on ; |
: ] ['] compiler IS parser state on ; |
|
|
\ locals stuff needed for control structures |
\ locals stuff needed for control structures |
|
|
: compile-lp+! ( n -- ) |
: compile-lp+! ( n -- ) |
dup negate locals-size +! |
dup negate locals-size +! |
0 over = if |
0 over = if |
else -4 over = if postpone -4lp+! |
else -1 cells over = if postpone lp- |
else 8 over = if postpone 8lp+! |
else 1 floats over = if postpone lp+ |
else 16 over = if postpone 16lp+! |
else 2 floats over = if postpone lp+2 |
else postpone lp+!# dup , |
else postpone lp+!# dup , |
then then then then drop ; |
then then then then drop ; |
|
|
Line 561 variable dead-code \ true if normal code
|
Line 560 variable dead-code \ true if normal code
|
|
|
: THEN ( orig -- ) |
: THEN ( orig -- ) |
dup orig? |
dup orig? |
dead-code @ |
dead-orig = |
if |
if |
dead-orig = |
>resolve drop |
if |
|
>resolve drop |
|
else |
|
>resolve set-locals-size-list dead-code off |
|
then |
|
else |
else |
dead-orig = |
dead-code @ |
if |
if |
>resolve drop |
>resolve set-locals-size-list dead-code off |
else \ both live |
else \ both live |
over list-size adjust-locals-size |
over list-size adjust-locals-size |
>resolve |
>resolve |
Line 797 Avariable leave-sp leave-stack 3 cells
|
Line 791 Avariable leave-sp leave-stack 3 cells
|
\ information through global variables), but they are useful for dealing |
\ information through global variables), but they are useful for dealing |
\ with existing/independent defining words |
\ with existing/independent defining words |
|
|
defer header |
defer (header) |
|
defer header ' (header) IS header |
|
|
: name, ( "name" -- ) |
: name, ( "name" -- ) |
name c@ |
name |
dup $1F u> -&19 and throw ( is name too long? ) |
dup $1F u> -&19 and throw ( is name too long? ) |
1+ chars allot align ; |
dup c, here swap chars dup allot move align ; |
: input-stream-header ( "name" -- ) |
: input-stream-header ( "name" -- ) |
\ !! this is f83-implementation-dependent |
\ !! this is f83-implementation-dependent |
align here last ! -1 A, |
align here last ! -1 A, |
Line 810 defer header
|
Line 805 defer header
|
|
|
: input-stream ( -- ) \ general |
: input-stream ( -- ) \ general |
\ switches back to getting the name from the input stream ; |
\ switches back to getting the name from the input stream ; |
['] input-stream-header IS header ; |
['] input-stream-header IS (header) ; |
|
|
' input-stream-header IS header |
' input-stream-header IS (header) |
|
|
\ !! make that a 2variable |
\ !! make that a 2variable |
create nextname-buffer 32 chars allot |
create nextname-buffer 32 chars allot |
Line 830 create nextname-buffer 32 chars allot
|
Line 825 create nextname-buffer 32 chars allot
|
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) ; |
|
|
: noname-header ( -- ) |
: noname-header ( -- ) |
0 last ! |
0 last ! |
Line 838 create nextname-buffer 32 chars allot
|
Line 833 create nextname-buffer 32 chars allot
|
|
|
: noname ( -- ) \ general |
: noname ( -- ) \ general |
\ the next defined word remains anonymous. The xt of that word is given by lastxt |
\ the next defined word remains anonymous. The xt of that word is given by lastxt |
['] noname-header IS header ; |
['] noname-header IS (header) ; |
|
|
: lastxt ( -- xt ) \ general |
: lastxt ( -- xt ) \ general |
\ xt is the execution token of the last word defined. The main purpose of this word is to get the xt of words defined using noname |
\ xt is the execution token of the last word defined. The main purpose of this word is to get the xt of words defined using noname |
Line 1024 Variable warnings G -1 warnings T !
|
Line 1019 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= if drop -&13 bounce then ; |
: ' ( "name" -- addr ) name sfind 0= if -&13 bounce then ; |
: ['] ( "name" -- addr ) ' postpone ALiteral ; immediate |
: ['] ( "name" -- addr ) ' postpone ALiteral ; immediate |
\ Input 13feb93py |
\ Input 13feb93py |
|
|
Line 1164 create nl$ 1 c, A c, 0 c, \ gnu includes
|
Line 1159 create nl$ 1 c, A c, 0 c, \ gnu includes
|
: include-file ( i*x fid -- j*x ) |
: include-file ( i*x fid -- j*x ) |
push-file loadfile ! |
push-file loadfile ! |
0 loadline ! blk off ['] read-loop catch |
0 loadline ! blk off ['] read-loop catch |
loadfile @ close-file swap |
loadfile @ close-file swap 2dup or |
pop-file throw throw ; |
pop-file drop throw throw ; |
|
|
create pathfilenamebuf 256 chars allot \ !! make this grow on demand |
create pathfilenamebuf 256 chars allot \ !! make this grow on demand |
|
|
Line 1195 create pathfilenamebuf 256 chars allot \
|
Line 1190 create pathfilenamebuf 256 chars allot \
|
open-path-file ( file-id c-addr2 u2 ) |
open-path-file ( file-id c-addr2 u2 ) |
dup allocate throw over loadfilename 2! ( file-id c-addr2 u2 ) |
dup allocate throw over loadfilename 2! ( file-id c-addr2 u2 ) |
drop loadfilename 2@ move |
drop loadfilename 2@ move |
include-file |
['] include-file catch |
\ don't free filenames; they don't take much space |
\ don't free filenames; they don't take much space |
\ and are used for debugging |
\ and are used for debugging |
r> r> loadfilename 2! ; |
r> r> loadfilename 2! throw ; |
|
|
\ HEX DECIMAL 2may93jaw |
\ HEX DECIMAL 2may93jaw |
|
|
Line 1212 create pathfilenamebuf 256 chars allot \
|
Line 1207 create pathfilenamebuf 256 chars allot \
|
\ INCLUDE 9may93jaw |
\ INCLUDE 9may93jaw |
|
|
: include ( "file" -- ) |
: include ( "file" -- ) |
bl word count included ; |
name included ; |
|
|
\ RECURSE 17may93jaw |
\ RECURSE 17may93jaw |
|
|
Line 1289 DEFER DOERROR
|
Line 1284 DEFER DOERROR
|
ELSE |
ELSE |
type ." :" dec. |
type ." :" dec. |
cr dup 2over type cr drop |
cr dup 2over type cr drop |
nip -trailing ( line-start index2 ) |
nip -trailing 1- ( line-start index2 ) |
0 >r BEGIN |
0 >r BEGIN |
1- 2dup + c@ bl > WHILE |
2dup + c@ bl > WHILE |
r> 1+ >r dup 0< UNTIL THEN 1+ |
r> 1+ >r 1- dup 0< UNTIL THEN 1+ |
( line-start index1 ) |
( line-start index1 ) |
typewhite |
typewhite |
r> 1 max 0 ?do \ we want at least one "^", even if the length is 0 |
r> 1 max 0 ?do \ we want at least one "^", even if the length is 0 |