version 1.8, 1994/06/17 12:35:07
|
version 1.9, 1994/07/07 14:59:23
|
Line 79 DOES> ( n -- ) + c@ ;
|
Line 79 DOES> ( n -- ) + c@ ;
|
\ name> found 17dec92py |
\ name> found 17dec92py |
|
|
: (name>) ( nfa -- cfa ) count $1F and + aligned ; |
: (name>) ( nfa -- cfa ) count $1F and + aligned ; |
: name> ( nfa -- cfa ) |
: name> ( nfa -- cfa ) cell+ |
dup (name>) swap c@ $80 and 0= IF @ THEN ; |
dup (name>) swap c@ $80 and 0= IF @ THEN ; |
|
|
: found ( nfa -- cfa n ) cell+ |
: found ( nfa -- cfa n ) cell+ |
dup c@ >r (name>) r@ $80 and 0= IF @ THEN |
dup c@ >r (name>) r@ $80 and 0= IF @ THEN |
\ -1 r@ $40 and IF 1- THEN |
-1 r@ $40 and IF 1- THEN |
-1 r> $20 and IF negate THEN ; |
r> $20 and IF negate THEN ; |
|
|
\ (find) 17dec92py |
\ (find) 17dec92py |
|
|
Line 590 variable dead-code \ true if normal code
|
Line 590 variable dead-code \ true if normal code
|
\ we have to store more than just the address of the branch, so the |
\ we have to store more than just the address of the branch, so the |
\ traditional linked list approach is no longer viable. |
\ traditional linked list approach is no longer viable. |
\ This is solved by storing the information about the leavings in a |
\ This is solved by storing the information about the leavings in a |
\ special stack. The leavings of different DO-LOOPs are separated |
\ special stack. |
\ by a 0 entry |
|
|
|
\ !! remove the fixed size limit. 'Tis not hard. |
\ !! remove the fixed size limit. 'Tis not hard. |
20 constant leave-stack-size |
20 constant leave-stack-size |
create leave-stack 60 cells allot |
create leave-stack 60 cells allot |
Avariable leave-sp leave-stack leave-sp ! |
Avariable leave-sp leave-stack 3 cells + leave-sp ! |
|
|
: clear-leave-stack ( -- ) |
: clear-leave-stack ( -- ) |
leave-stack leave-sp ! ; |
leave-stack leave-sp ! ; |
Line 617 Avariable leave-sp leave-stack leave-sp
|
Line 616 Avariable leave-sp leave-stack leave-sp
|
: leave> ( -- orig ) |
: leave> ( -- orig ) |
\ pop from leave-stack |
\ pop from leave-stack |
leave-sp @ |
leave-sp @ |
dup leave-stack <= abort" leave-stack empty" |
dup leave-stack <= IF |
|
drop 0 0 0 EXIT THEN |
cell - dup @ swap |
cell - dup @ swap |
cell - dup @ swap |
cell - dup @ swap |
cell - dup @ swap |
cell - dup @ swap |
leave-sp ! ; |
leave-sp ! ; |
|
|
: done ( -- ) |
: DONE ( orig -- ) drop >r drop |
\ !! the original done had ( addr -- ) |
\ !! the original done had ( addr -- ) |
begin |
begin |
leave> |
leave> |
dup |
over r@ u>= |
while |
while |
POSTPONE then |
POSTPONE then |
repeat |
repeat |
2drop drop ; immediate |
>leave rdrop ; immediate restrict |
|
|
: LEAVE ( -- ) |
: LEAVE ( -- ) |
POSTPONE ahead |
POSTPONE ahead |
>leave ; immediate |
>leave ; immediate restrict |
|
|
: ?LEAVE ( -- ) |
: ?LEAVE ( -- ) |
POSTPONE 0= POSTPONE if |
POSTPONE 0= POSTPONE if |
>leave ; immediate |
>leave ; immediate restrict |
|
|
: DO ( -- do-sys ) |
: DO ( -- do-sys ) |
POSTPONE (do) |
POSTPONE (do) |
POSTPONE begin drop do-dest |
POSTPONE begin drop do-dest |
0 0 0 >leave ; immediate |
( 0 0 0 >leave ) ; immediate restrict |
|
|
: ?DO ( -- do-sys ) |
: ?DO ( -- do-sys ) |
0 0 0 >leave |
( 0 0 0 >leave ) |
POSTPONE (?do) |
POSTPONE (?do) |
>mark >leave |
>mark >leave |
POSTPONE begin drop do-dest ; immediate |
POSTPONE begin drop do-dest ; immediate restrict |
|
|
: FOR ( -- do-sys ) |
: FOR ( -- do-sys ) |
POSTPONE (for) |
POSTPONE (for) |
POSTPONE begin drop do-dest |
POSTPONE begin drop do-dest |
0 0 0 >leave ; immediate |
( 0 0 0 >leave ) ; immediate restrict |
|
|
\ LOOP etc. are just like UNTIL |
\ LOOP etc. are just like UNTIL |
|
|
: loop-like ( do-sys xt1 xt2 -- ) |
: loop-like ( do-sys xt1 xt2 -- ) |
rot do-dest? |
>r >r 0 cs-pick swap cell - swap 1 cs-roll r> r> rot do-dest? |
until-like POSTPONE done POSTPONE unloop ; |
until-like POSTPONE done POSTPONE unloop ; |
|
|
: LOOP ( do-sys -- ) |
: LOOP ( do-sys -- ) |
['] (loop) ['] (loop)-lp+!# loop-like ; immediate |
['] (loop) ['] (loop)-lp+!# loop-like ; immediate restrict |
|
|
: +LOOP ( do-sys -- ) |
: +LOOP ( do-sys -- ) |
['] (+loop) ['] (+loop)-lp+!# loop-like ; immediate |
['] (+loop) ['] (+loop)-lp+!# loop-like ; immediate restrict |
|
|
\ A symmetric version of "+LOOP". I.e., "-high -low ?DO -inc S+LOOP" |
\ A symmetric version of "+LOOP". I.e., "-high -low ?DO -inc S+LOOP" |
\ will iterate as often as "high low ?DO inc S+LOOP". For positive |
\ will iterate as often as "high low ?DO inc S+LOOP". For positive |
\ increments it behaves like "+LOOP". Use S+LOOP instead of +LOOP for |
\ increments it behaves like "+LOOP". Use S+LOOP instead of +LOOP for |
\ negative increments. |
\ negative increments. |
: S+LOOP ( do-sys -- ) |
: S+LOOP ( do-sys -- ) |
['] (s+loop) ['] (s+loop)-lp+!# loop-like ; immediate |
['] (s+loop) ['] (s+loop)-lp+!# loop-like ; immediate restrict |
|
|
: NEXT ( do-sys -- ) |
: NEXT ( do-sys -- ) |
['] (next) ['] (next)-lp+!# loop-like ; immediate |
['] (next) ['] (next)-lp+!# loop-like ; immediate restrict |
|
|
\ Structural Conditionals 12dec92py |
\ Structural Conditionals 12dec92py |
|
|
Line 717 Avariable leave-sp leave-stack leave-sp
|
Line 717 Avariable leave-sp leave-stack leave-sp
|
|
|
: flag! ( 8b -- ) last @ cell+ tuck c@ xor swap c! ; |
: flag! ( 8b -- ) last @ cell+ tuck c@ xor swap c! ; |
: immediate $20 flag! ; |
: immediate $20 flag! ; |
\ : restrict $40 flag! ; |
: restrict $40 flag! ; |
' noop alias restrict |
\ ' noop alias restrict |
|
|
\ Header 23feb93py |
\ Header 23feb93py |
|
|
Line 777 create nextname-buffer 32 chars allot
|
Line 777 create nextname-buffer 32 chars allot
|
: name>string ( nfa -- addr count ) |
: name>string ( nfa -- addr count ) |
cell+ count $1F and ; |
cell+ count $1F and ; |
|
|
Create ??? ," ???" |
Create ??? 0 , 3 c, char ? c, char ? c, char ? c, |
: >name ( cfa -- nfa ) |
: >name ( cfa -- nfa ) |
$21 cell do |
$21 cell do |
dup i - count $9F and + aligned over $80 + = if |
dup i - count $9F and + aligned over $80 + = if |
Line 1001 Create crtlkeys
|
Line 1001 Create crtlkeys
|
DEFER type \ defer type for a output buffer or fast |
DEFER type \ defer type for a output buffer or fast |
\ screen write |
\ screen write |
|
|
: (type) ( addr len -- ) |
\ : (type) ( addr len -- ) |
bounds ?DO I c@ emit LOOP ; |
\ bounds ?DO I c@ emit LOOP ; |
|
|
' (TYPE) IS Type |
' (TYPE) IS Type |
|
|
\ DEFER Emit |
DEFER Emit |
|
|
\ ' (Emit) IS Emit |
' (Emit) IS Emit |
|
|
\ : form ( -- rows cols ) &24 &80 ; |
\ : form ( -- rows cols ) &24 &80 ; |
\ form should be implemented using TERMCAPS or CURSES |
\ form should be implemented using TERMCAPS or CURSES |
Line 1087 create nl$ 1 c, A c, 0 c, \ gnu includes
|
Line 1087 create nl$ 1 c, A c, 0 c, \ gnu includes
|
|
|
\ RECURSE 17may93jaw |
\ RECURSE 17may93jaw |
|
|
: recurse last @ cell+ name> a, ; immediate restrict |
: recurse last @ ( cell+ ) name> a, ; immediate restrict |
\ !! does not work with anonymous words; use lastxt compile, |
\ !! does not work with anonymous words; use lastxt compile, |
|
|
\ */MOD */ 17may93jaw |
\ */MOD */ 17may93jaw |