version 1.9, 1994/07/07 14:59:23
|
version 1.10, 1994/07/08 15:00:51
|
Line 271 hex
|
Line 271 hex
|
r> handler ! rdrop rdrop rdrop 0 ; |
r> handler ! rdrop rdrop rdrop 0 ; |
|
|
: throw ( y1 .. ym error/0 -- y1 .. ym / z1 .. zn error ) |
: throw ( y1 .. ym error/0 -- y1 .. ym / z1 .. zn error ) |
?DUP IF |
?DUP IF |
handler @ rp! |
[ here 4 cells ! ] |
r> handler ! |
handler @ rp! |
r> lp! |
r> handler ! |
r> fp! |
r> lp! |
r> swap >r sp! r> |
r> fp! |
THEN ; |
r> swap >r sp! r> |
|
THEN ; |
|
|
\ Bouncing is very fine, |
\ Bouncing is very fine, |
\ programming without wasting time... jaw |
\ programming without wasting time... jaw |
Line 327 Defer notfound
|
Line 328 Defer notfound
|
|
|
\ locals stuff needed for control structures |
\ locals stuff needed for control structures |
|
|
variable locals-size \ this is the current size of the locals stack |
|
\ frame of the current word |
|
|
|
: compile-lp+! ( n -- ) |
: compile-lp+! ( n -- ) |
dup negate locals-size +! |
dup negate locals-size +! |
0 over = if |
0 over = if |
Line 346 variable locals-size \ this is the curre
|
Line 344 variable locals-size \ this is the curre
|
|
|
here 0 , \ just a dummy, the real value of locals-list is patched into it in glocals.fs |
here 0 , \ just a dummy, the real value of locals-list is patched into it in glocals.fs |
AConstant locals-list \ acts like a variable that contains |
AConstant locals-list \ acts like a variable that contains |
\ a linear list of locals names |
\ a linear list of locals names |
|
|
|
|
variable dead-code \ true if normal code at "here" would be dead |
variable dead-code \ true if normal code at "here" would be dead |
Line 715 Avariable leave-sp leave-stack 3 cells
|
Line 713 Avariable leave-sp leave-stack 3 cells
|
|
|
\ Header states 23feb93py |
\ Header states 23feb93py |
|
|
: flag! ( 8b -- ) last @ cell+ tuck c@ xor swap c! ; |
: flag! ( 8b -- ) |
|
last @ dup 0= abort" last word was headerless" |
|
cell+ tuck c@ xor swap c! ; |
: immediate $20 flag! ; |
: immediate $20 flag! ; |
: restrict $40 flag! ; |
: restrict $40 flag! ; |
\ ' noop alias restrict |
\ ' noop alias restrict |
Line 729 Avariable leave-sp leave-stack 3 cells
|
Line 729 Avariable leave-sp leave-stack 3 cells
|
defer header |
defer header |
|
|
: name, ( "name" -- ) |
: name, ( "name" -- ) |
name c@ 1+ chars allot align ; |
name c@ |
|
dup $1F u> &-19 and throw ( is name too long? ) |
|
1+ chars allot 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 754 create nextname-buffer 32 chars allot
|
Line 756 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 31 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 863 defer ;-hook ( sys2 -- sys1 )
|
Line 865 defer ;-hook ( sys2 -- sys1 )
|
: ; ( colon-sys -- ) ;-hook ?struc postpone exit reveal postpone [ ; |
: ; ( colon-sys -- ) ;-hook ?struc postpone exit reveal postpone [ ; |
immediate restrict |
immediate restrict |
|
|
: :noname ( -- xt colon-sys ) here [ :docol ] Literal cfa, 0 ] :-hook ; |
: :noname ( -- xt colon-sys ) |
|
0 last ! |
|
here [ :docol ] Literal cfa, 0 ] :-hook ; |
|
|
\ Search list handling 23feb93py |
\ Search list handling 23feb93py |
|
|
Line 1026 DEFER Emit
|
Line 1030 DEFER Emit
|
accept true |
accept true |
THEN |
THEN |
1 loadline +! |
1 loadline +! |
swap #tib ! >in off ; |
swap #tib ! 0 >in ! ; |
|
|
: Query ( -- ) loadfile off refill drop ; |
: Query ( -- ) 0 loadfile ! refill drop ; |
|
|
\ File specifiers 11jun93jaw |
\ File specifiers 11jun93jaw |
|
|
Line 1069 create nl$ 1 c, A c, 0 c, \ gnu includes
|
Line 1073 create nl$ 1 c, A c, 0 c, \ gnu includes
|
r> loadfile ! r> loadline ! r> linestart ! ; |
r> loadfile ! r> loadline ! r> linestart ! ; |
|
|
: included ( i*x addr u -- j*x ) |
: included ( i*x addr u -- j*x ) |
r/o open-file throw include-file ; |
loadfilename 2@ >r >r |
|
dup allocate throw over loadfilename 2! |
|
over loadfilename 2@ move |
|
r/o open-file throw include-file |
|
\ don't free filenames; they don't take much space |
|
\ and are used for debugging |
|
r> r> loadfilename 2! ; |
|
|
\ HEX DECIMAL 2may93jaw |
\ HEX DECIMAL 2may93jaw |
|
|
Line 1087 create nl$ 1 c, A c, 0 c, \ gnu includes
|
Line 1097 create nl$ 1 c, A c, 0 c, \ gnu includes
|
|
|
\ RECURSE 17may93jaw |
\ RECURSE 17may93jaw |
|
|
: recurse last @ ( cell+ ) name> a, ; immediate restrict |
: recurse ( -- ) |
\ !! does not work with anonymous words; use lastxt compile, |
lastxt compile, ; immediate restrict |
|
: recursive ( -- ) |
|
reveal ; immediate |
|
|
\ */MOD */ 17may93jaw |
\ */MOD */ 17may93jaw |
|
|
Line 1126 Defer .status
|
Line 1138 Defer .status
|
|
|
\ DOERROR (DOERROR) 13jun93jaw |
\ DOERROR (DOERROR) 13jun93jaw |
|
|
|
: dec. ( n -- ) |
|
\ print value in decimal representation |
|
base @ decimal swap . base ! ; |
|
|
|
: typewhite ( addr u -- ) |
|
\ like type, but white space is printed instead of the characters |
|
0 ?do |
|
dup i + c@ 9 = if \ check for tab |
|
9 |
|
else |
|
bl |
|
then |
|
emit |
|
loop |
|
drop ; |
|
|
DEFER DOERROR |
DEFER DOERROR |
|
|
: (DoError) ( throw-code -- ) |
: (DoError) ( throw-code -- ) |
LoadFile @ |
LoadFile @ |
IF |
IF |
." Error in line: " Loadline @ . cr |
cr loadfilename 2@ type ." :" Loadline @ dec. |
THEN |
THEN |
cr source type cr |
cr source type cr |
source drop >in @ -trailing |
source drop >in @ -trailing ( throw-code line-start index2 ) |
here c@ 1F min dup >r - 1- 0 max nip |
here c@ 1F min dup >r - 0 max ( throw-code line-start index1 ) |
dup spaces |
typewhite |
IF |
r> 1 max 0 ?do \ we want at least one "^", even if the length is 0 |
." ^" |
." ^" |
THEN |
loop |
r> 0 ?DO |
dup -2 = |
." -" |
IF |
LOOP |
"error @ ?dup |
." ^" |
IF |
dup -2 = |
cr count type |
IF |
THEN |
"error @ ?dup |
drop |
IF |
ELSE |
cr count type |
.error |
THEN |
THEN |
drop |
normal-dp dpp ! ; |
ELSE |
|
.error |
|
THEN |
|
normal-dp dpp ! ; |
|
|
|
' (DoError) IS DoError |
' (DoError) IS DoError |
|
|
Line 1189 Variable argc
|
Line 1213 Variable argc
|
: script? ( -- flag ) 0 arg 1 arg dup 3 pick - /string compare 0= ; |
: script? ( -- flag ) 0 arg 1 arg dup 3 pick - /string compare 0= ; |
|
|
: cold ( -- ) |
: cold ( -- ) |
argc @ 1 > |
argc @ 1 > |
IF script? |
IF script? |
IF 1 arg ['] included ELSE get-args ['] interpret THEN |
IF |
catch ?dup IF dup >r DoError cr r> (bye) THEN THEN |
1 arg ['] included |
." ANS FORTH-93 (c) 1993 by the ANS FORTH-93 Team" cr quit ; |
ELSE |
|
get-args ['] interpret |
|
THEN |
|
catch ?dup |
|
IF |
|
dup >r DoError cr r> (bye) |
|
THEN |
|
THEN |
|
cr ." GNU Forth 0.0alpha, Copyright (C) 1994 Free Software Foundation" |
|
cr ." GNU Forth comes with ABSOLUTELY NO WARRANTY; for details type `license'" |
|
cr quit ; |
|
|
: boot ( **env **argv argc -- ) |
: boot ( **env **argv argc -- ) |
argc ! argv ! env ! main-task up! |
argc ! argv ! env ! main-task up! |