version 1.1, 1994/02/11 16:30:46
|
version 1.5, 1994/05/07 14:55:58
|
Line 45 DOES> ( n -- ) + c@ ;
|
Line 45 DOES> ( n -- ) + c@ ;
|
|
|
\ here allot , c, A, 17dec92py |
\ here allot , c, A, 17dec92py |
|
|
|
: dp ( -- addr ) dpp @ ; |
: here ( -- here ) dp @ ; |
: here ( -- here ) dp @ ; |
: allot ( n -- ) dp +! ; |
: allot ( n -- ) dp +! ; |
: c, ( c -- ) here 1 chars allot c! ; |
: c, ( c -- ) here 1 chars allot c! ; |
Line 243 hex
|
Line 244 hex
|
\ !! allow the user to add rollback actions anton |
\ !! allow the user to add rollback actions anton |
\ !! use a separate exception stack? anton |
\ !! use a separate exception stack? anton |
|
|
|
: lp@ ( -- addr ) |
|
laddr# [ 0 , ] ; |
|
|
: catch ( x1 .. xn xt -- y1 .. ym 0 / z1 .. zn error ) |
: catch ( x1 .. xn xt -- y1 .. ym 0 / z1 .. zn error ) |
>r sp@ r> swap \ don't count xt! jaw |
>r sp@ r> swap >r \ don't count xt! jaw |
>r handler @ >r rp@ handler ! execute |
fp@ >r |
r> handler ! rdrop 0 ; |
lp@ >r |
: throw ( y1 .. ym error/0 -- y1 .. ym / z1 .. zn ) |
handler @ >r |
dup 0= IF drop EXIT THEN |
rp@ handler ! |
handler @ rp! r> handler ! r> swap >r sp! r> ; |
execute |
|
r> handler ! rdrop rdrop 0 ; |
|
: throw ( y1 .. ym error/0 -- y1 .. ym / z1 .. zn error ) |
|
?DUP IF |
|
handler @ rp! |
|
r> handler ! |
|
r> lp! |
|
r> fp! |
|
r> swap >r sp! r> |
|
THEN ; |
\ Bouncing is very fine, |
\ Bouncing is very fine, |
\ programming without wasting time... jaw |
\ programming without wasting time... jaw |
: bounce ( y1 .. ym error/0 -- y1 .. ym / z1 .. zn ) |
: bounce ( y1 .. ym error/0 -- y1 .. ym error / y1 .. ym ) |
\ a throw without data stack restauration? anton !! stack diagram bad |
\ a throw without data or fp stack restauration |
dup 0= IF drop EXIT THEN |
?DUP IF |
handler @ rp! r> handler ! r> drop ; |
handler @ rp! |
|
r> handler ! |
|
r> lp! |
|
rdrop |
|
rdrop |
|
THEN ; |
|
|
\ ?stack 23feb93py |
\ ?stack 23feb93py |
|
|
Line 268 Defer parser
|
Line 286 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 286 Defer notfound
|
Line 304 Defer notfound
|
: compiler ( name -- ) find ?dup |
: compiler ( name -- ) find ?dup |
IF 0> IF execute EXIT THEN compile, EXIT THEN number? dup |
IF 0> IF execute EXIT THEN compile, EXIT THEN number? dup |
IF 0> IF swap postpone Literal THEN postpone Literal |
IF 0> IF swap postpone Literal THEN postpone Literal |
ELSE notfound THEN ; |
ELSE drop notfound THEN ; |
|
|
: [ ['] interpreter IS parser state off ; immediate |
: [ ['] interpreter IS parser state off ; immediate |
: ] ['] compiler IS parser state on ; |
: ] ['] compiler IS parser state on ; |
Line 330 Defer notfound
|
Line 348 Defer notfound
|
|
|
\ Structural Conditionals 12dec92py |
\ Structural Conditionals 12dec92py |
|
|
|
variable locals-size \ this is the current size of the locals stack |
|
\ frame of the current word |
|
|
|
: compile-lp+!# ( n -- ) |
|
?DUP IF |
|
dup negate locals-size +! |
|
postpone lp+!# , |
|
THEN ; |
|
|
|
\ : EXIT ( -- ) |
|
\ locals-size @ compile-lp+!# POSTPONE ;s ; immediate restrict |
|
\ : ?EXIT ( -- ) |
|
\ postpone IF postpone EXIT postpone THEN ; immediate restrict |
|
|
Variable leavings |
Variable leavings |
|
|
: (leave) here leavings @ , leavings ! ; |
: (leave) here leavings @ , leavings ! ; |
: LEAVE postpone branch (leave) ; immediate restrict |
: LEAVE postpone branch (leave) ; immediate restrict |
: ?LEAVE postpone 0= postpone ?branch (leave) ; |
: ?LEAVE postpone 0= postpone ?branch (leave) ; |
immediate restrict |
immediate restrict |
|
: DONE ( addr -- ) |
: DONE ( addr -- ) leavings @ |
leavings @ |
BEGIN 2dup u<= WHILE dup @ swap >resolve REPEAT |
BEGIN |
|
2dup u<= |
|
WHILE |
|
dup @ swap >resolve |
|
REPEAT |
leavings ! drop ; immediate restrict |
leavings ! drop ; immediate restrict |
|
|
\ Structural Conditionals 12dec92py |
\ Structural Conditionals 12dec92py |
Line 411 defer header
|
Line 447 defer header
|
' input-stream-header IS header |
' input-stream-header IS header |
|
|
\ !! make that a 2variable |
\ !! make that a 2variable |
create nextname-string 2 cells allot \ should we use a buffer that keeps the name? |
create nextname-buffer 32 chars allot |
|
|
: nextname-header ( -- ) |
: nextname-header ( -- ) |
\ !! f83-implementation-dependent |
\ !! f83-implementation-dependent |
nextname-string 2@ |
nextname-buffer count |
align here last ! -1 A, |
align here last ! -1 A, |
dup c, here swap chars dup allot move align |
dup c, here swap chars dup allot move align |
$80 flag! |
$80 flag! |
Line 423 create nextname-string 2 cells allot \ s
|
Line 459 create nextname-string 2 cells allot \ s
|
|
|
\ 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 |
nextname-string 2! |
dup 31 u> -19 and throw ( is name too long? ) |
|
nextname-buffer c! ( c-addr ) |
|
nextname-buffer count move |
['] nextname-header IS header ; |
['] nextname-header IS header ; |
|
|
: noname-header ( -- ) |
: noname-header ( -- ) |
Line 466 Create ??? ," ???"
|
Line 504 Create ??? ," ???"
|
|
|
\ direct threading is implementation dependent |
\ direct threading is implementation dependent |
|
|
: Create Header reveal [ :dovar ] ALiteral cfa, ; |
: Create Header reveal [ :dovar ] Literal cfa, ; |
|
|
\ DOES> 17mar93py |
\ DOES> 17mar93py |
|
|
: DOES> state @ IF postpone (;code) dodoes, |
: DOES> ( compilation: -- ) |
ELSE dodoes, here !does 0 ] THEN ; immediate |
state @ |
|
IF |
|
;-hook postpone (;code) dodoes, |
|
ELSE |
|
dodoes, here !does 0 ] |
|
THEN |
|
:-hook ; immediate |
|
|
\ Create Variable User Constant 17mar93py |
\ Create Variable User Constant 17mar93py |
|
|
Line 483 Create ??? ," ???"
|
Line 527 Create ??? ," ???"
|
: User Variable ; |
: User Variable ; |
: AUser AVariable ; |
: AUser AVariable ; |
|
|
: (Constant) Header reveal [ :docon ] ALiteral cfa, ; |
: (Constant) Header reveal [ :docon ] Literal cfa, ; |
: Constant (Constant) , ; |
: Constant (Constant) , ; |
: AConstant (Constant) A, ; |
: AConstant (Constant) A, ; |
: 2CONSTANT ( w1 w2 "name" -- ) \ double |
|
(constant) 2, ; |
: 2CONSTANT |
|
create ( w1 w2 "name" -- ) |
|
2, |
|
does> ( -- w1 w2 ) |
|
2@ ; |
|
|
\ IS Defer What's Defers TO 24feb93py |
\ IS Defer What's Defers TO 24feb93py |
|
|
: Defer Create ['] noop A, DOES> @ execute ; |
: Defer |
|
Create ( -- ) |
|
['] noop A, |
|
DOES> ( ??? ) |
|
@ execute ; |
|
|
: IS ( addr "name" -- ) |
: IS ( addr "name" -- ) |
' >body |
' >body |
Line 509 Create ??? ," ???"
|
Line 561 Create ??? ," ???"
|
|
|
\ : ; 24feb93py |
\ : ; 24feb93py |
|
|
: : ( -- colon-sys ) Header [ :docol ] ALiteral cfa, 0 ] ; |
defer :-hook ( sys1 -- sys2 ) |
: ; ( colon-sys -- ) ?struc postpone exit reveal postpone [ ; |
defer ;-hook ( sys2 -- sys1 ) |
|
|
|
: EXIT ( -- ) postpone ;s ; immediate |
|
|
|
: : ( -- colon-sys ) Header [ :docol ] Literal cfa, 0 ] :-hook ; |
|
: ; ( colon-sys -- ) ;-hook ?struc postpone exit reveal postpone [ ; |
immediate restrict |
immediate restrict |
: :noname ( -- xt colon-sys ) here [ ' : @ ] ALiteral cfa, 0 ] ; |
|
|
: :noname ( -- xt colon-sys ) here [ :docol ] Literal cfa, 0 ] :-hook ; |
|
|
\ Search list handling 23feb93py |
\ Search list handling 23feb93py |
|
|
AVariable current |
AVariable current |
|
|
: last? ( -- false / nfa nfa ) last @ ?dup ; |
: last? ( -- false / nfa nfa ) last @ ?dup ; |
: (reveal) ( -- ) last? |
: (reveal) ( -- ) |
IF dup @ 0< |
last? |
IF current @ @ over ! current @ ! |
IF |
ELSE drop THEN THEN ; |
dup @ 0< |
|
IF |
|
current @ @ over ! current @ ! |
|
ELSE |
|
drop |
|
THEN |
|
THEN ; |
|
|
\ object oriented search list 17mar93py |
\ object oriented search list 17mar93py |
|
|
\ Search list table: find reveal |
\ word list structure: |
|
\ struct |
|
\ 1 cells: field find-method \ xt: ( c_addr u w1 -- name-id ) w1 is a method-\ specific wordlist-id (not the same as wid) |
|
\ 1 cells: field reveal-method \ xt: ( -- ) |
|
\ \ !! what else |
|
\ end-struct wordlist-map-struct |
|
|
|
\ struct |
|
\ 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 ???? |
|
\ 1 cells: field ???? |
|
\ end-struct wordlist-struct |
|
|
|
|
|
\ Search list table: find reveal |
Create f83search ' (f83find) A, ' (reveal) A, |
Create f83search ' (f83find) A, ' (reveal) A, |
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 748 Defer .status
|
Line 826 Defer .status
|
DEFER DOERROR |
DEFER DOERROR |
|
|
: (DoError) ( throw-code -- ) |
: (DoError) ( throw-code -- ) |
LoadFile @ IF ." Error in line: " Loadline @ . cr THEN |
LoadFile @ |
|
IF |
|
." Error in line: " Loadline @ . cr |
|
THEN |
cr source type cr |
cr source type cr |
source drop >in @ -trailing |
source drop >in @ -trailing |
here c@ 1F min dup >r - 1- 0 max nip |
here c@ 1F min dup >r - 1- 0 max nip |
dup spaces IF ." ^" THEN r> 0 ?DO ." -" LOOP ." ^" |
dup spaces |
|
IF |
|
." ^" |
|
THEN |
|
r> 0 ?DO |
|
." -" |
|
LOOP |
|
." ^" |
dup -2 = |
dup -2 = |
IF "error @ ?dup IF cr count type THEN drop |
IF |
ELSE .error THEN ; |
"error @ ?dup |
|
IF |
|
cr count type |
|
THEN |
|
drop |
|
ELSE |
|
.error |
|
THEN |
|
normal-dp dpp ! ; |
|
|
' (DoError) IS DoError |
' (DoError) IS DoError |
|
|
: quit r0 @ rp! handler off >tib @ >r |
: quit r0 @ rp! handler off >tib @ >r |
BEGIN postpone [ ['] 'quit catch dup WHILE |
BEGIN |
DoError r@ >tib ! |
postpone [ |
REPEAT drop r> >tib ! ; |
['] 'quit CATCH dup |
|
WHILE |
|
DoError r@ >tib ! |
|
REPEAT |
|
drop r> >tib ! ; |
|
|
\ Cold 13feb93py |
\ Cold 13feb93py |
|
|
Line 785 Variable argc
|
Line 885 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 ( -- ) argc @ 1 > |
: cold ( -- ) |
|
argc @ 1 > |
IF script? |
IF script? |
IF 1 arg ['] included ELSE get-args ['] interpret THEN |
IF 1 arg ['] included ELSE get-args ['] interpret THEN |
catch ?dup IF dup >r DoError cr r> (bye) THEN THEN |
catch ?dup IF dup >r DoError cr r> (bye) THEN THEN |
." ANS FORTH-93 (c) 1993 by the ANS FORTH-93 Team" cr quit ; |
." ANS FORTH-93 (c) 1993 by the ANS FORTH-93 Team" cr quit ; |
|
|
: boot ( **env **argv argc -- ) |
: boot ( **env **argv argc -- ) |
argc ! argv ! env ! |
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 cr 0 (bye) ; |