version 1.20, 1994/09/12 19:00:32
|
version 1.23, 1994/11/11 16:10:12
|
Line 66 DOES> ( n -- ) + c@ ;
|
Line 66 DOES> ( n -- ) + c@ ;
|
bl c, |
bl c, |
LOOP ; |
LOOP ; |
|
|
|
: chars ; immediate |
|
|
: A! ( addr1 addr2 -- ) dup relon ! ; |
: A! ( addr1 addr2 -- ) dup relon ! ; |
: A, ( addr -- ) here cell allot A! ; |
: A, ( addr -- ) here cell allot A! ; |
Line 173 Defer source
|
Line 173 Defer source
|
: [char] ( 'char' -- n ) char postpone Literal ; immediate |
: [char] ( 'char' -- n ) char postpone Literal ; immediate |
' [char] Alias Ascii immediate |
' [char] Alias Ascii immediate |
|
|
: (compile) ( -- ) r> dup cell+ >r @ A, ; |
: (compile) ( -- ) r> dup cell+ >r @ compile, ; |
: postpone ( "name" -- ) |
: postpone ( "name" -- ) |
name sfind dup 0= abort" Can't compile " |
name sfind dup 0= abort" Can't compile " |
0> IF A, ELSE postpone (compile) A, THEN ; |
0> IF compile, ELSE postpone (compile) A, THEN ; |
immediate restrict |
immediate restrict |
|
|
\ Use (compile) for the old behavior of compile! |
\ Use (compile) for the old behavior of compile! |
Line 244 decimal
|
Line 244 decimal
|
Create spaces bl 80 times \ times from target compiler! 11may93jaw |
Create spaces bl 80 times \ times from target compiler! 11may93jaw |
DOES> ( u -- ) swap |
DOES> ( u -- ) swap |
0 max 0 ?DO I' I - &80 min 2dup type +LOOP drop ; |
0 max 0 ?DO I' I - &80 min 2dup type +LOOP drop ; |
|
Create backspaces 08 80 times \ times from target compiler! 11may93jaw |
|
DOES> ( u -- ) swap |
|
0 max 0 ?DO I' I - &80 min 2dup type +LOOP drop ; |
hex |
hex |
: space 1 spaces ; |
: space 1 spaces ; |
|
|
Line 417 AConstant locals-list \ acts like a vari
|
Line 420 AConstant locals-list \ acts like a vari
|
|
|
|
|
variable dead-code \ true if normal code at "here" would be dead |
variable dead-code \ true if normal code at "here" would be dead |
|
variable backedge-locals |
: unreachable ( -- ) |
\ contains the locals list that BEGIN will assume to be live on |
\ declares the current point of execution as unreachable |
\ the back edge if the BEGIN is unreachable from above. Set by |
dead-code on ; |
\ ASSUME-LIVE, reset by UNREACHABLE. |
|
|
|
: UNREACHABLE ( -- ) |
|
\ declares the current point of execution as unreachable |
|
dead-code on |
|
0 backedge-locals ! ; immediate |
|
|
|
: ASSUME-LIVE ( orig -- orig ) |
|
\ used immediateliy before a BEGIN that is not reachable from |
|
\ above. causes the BEGIN to assume that the same locals are live |
|
\ as at the orig point |
|
dup orig? |
|
2 pick backedge-locals ! ; immediate |
|
|
\ locals list operations |
\ locals list operations |
|
|
: common-list ( list1 list2 -- list3 ) |
: common-list ( list1 list2 -- list3 ) |
Line 546 variable dead-code \ true if normal code
|
Line 561 variable dead-code \ true if normal code
|
\ Structural Conditionals 12dec92py |
\ Structural Conditionals 12dec92py |
|
|
: AHEAD ( -- orig ) |
: AHEAD ( -- orig ) |
POSTPONE branch >mark unreachable ; immediate restrict |
POSTPONE branch >mark POSTPONE unreachable ; immediate restrict |
|
|
: IF ( -- orig ) |
: IF ( -- orig ) |
POSTPONE ?branch >mark ; immediate restrict |
POSTPONE ?branch >mark ; immediate restrict |
Line 588 variable dead-code \ true if normal code
|
Line 603 variable dead-code \ true if normal code
|
|
|
: BEGIN ( -- dest ) |
: BEGIN ( -- dest ) |
dead-code @ if |
dead-code @ if |
\ set up an assumption of the locals visible here |
\ set up an assumption of the locals visible here. if the |
\ currently we just take the top cs-item |
\ users want something to be visible, they have to declare |
\ it would be more intelligent to take the top orig |
\ that using ASSUME-LIVE |
\ but that can be arranged by the user |
backedge-locals @ set-locals-size-list |
dup defstart <> if |
|
dup cs-item? |
|
2 pick |
|
else |
|
0 |
|
then |
|
set-locals-size-list |
|
then |
then |
cs-push-part dest |
cs-push-part dest |
dead-code off ; immediate restrict |
dead-code off ; immediate restrict |
Line 614 variable dead-code \ true if normal code
|
Line 622 variable dead-code \ true if normal code
|
POSTPONE branch |
POSTPONE branch |
<resolve |
<resolve |
check-begin |
check-begin |
unreachable ; immediate restrict |
POSTPONE unreachable ; immediate restrict |
|
|
\ UNTIL (the current control flow may join an earlier one or continue): |
\ UNTIL (the current control flow may join an earlier one or continue): |
\ Similar to AGAIN. The new locals-list and locals-size are the current |
\ Similar to AGAIN. The new locals-list and locals-size are the current |
Line 746 Avariable leave-sp leave-stack 3 cells
|
Line 754 Avariable leave-sp leave-stack 3 cells
|
: EXIT ( -- ) |
: EXIT ( -- ) |
0 adjust-locals-size |
0 adjust-locals-size |
POSTPONE ;s |
POSTPONE ;s |
unreachable ; immediate restrict |
POSTPONE unreachable ; immediate restrict |
|
|
: ?EXIT ( -- ) |
: ?EXIT ( -- ) |
POSTPONE if POSTPONE exit POSTPONE then ; immediate restrict |
POSTPONE if POSTPONE exit POSTPONE then ; immediate restrict |
Line 1033 Variable warnings G -1 warnings T !
|
Line 1041 Variable warnings G -1 warnings T !
|
|
|
: bell #bell emit ; |
: bell #bell emit ; |
|
|
: backspaces 0 ?DO #bs emit LOOP ; |
\ : backspaces 0 ?DO #bs emit LOOP ; |
: >string ( span addr pos1 -- span addr pos1 addr2 len ) |
: >string ( span addr pos1 -- span addr pos1 addr2 len ) |
over 3 pick 2 pick chars /string ; |
over 3 pick 2 pick chars /string ; |
: type-rest ( span addr pos1 -- span addr pos1 back ) |
: type-rest ( span addr pos1 -- span addr pos1 back ) |
Line 1050 Variable warnings G -1 warnings T !
|
Line 1058 Variable warnings G -1 warnings T !
|
: back dup IF 1- #bs emit ELSE #bell emit THEN 0 ; |
: back dup IF 1- #bs emit ELSE #bell emit THEN 0 ; |
: forw 2 pick over <> IF 2dup + c@ emit 1+ ELSE #bell emit THEN 0 ; |
: forw 2 pick over <> IF 2dup + c@ emit 1+ ELSE #bell emit THEN 0 ; |
|
|
Create crtlkeys |
Create ctrlkeys |
] false false back false false false forw false |
] false false back false false false forw false |
?del false (ret) false false (ret) false false |
?del false (ret) false false (ret) false false |
false false false false false false false false |
false false false false false false false false |
false false false false false false false false [ |
false false false false false false false false [ |
|
|
|
defer everychar |
|
' noop IS everychar |
|
|
: decode ( max span addr pos1 key -- max span addr pos2 flag ) |
: decode ( max span addr pos1 key -- max span addr pos2 flag ) |
|
everychar |
dup #del = IF drop #bs THEN \ del is rubout |
dup #del = IF drop #bs THEN \ del is rubout |
dup bl < IF cells crtlkeys + @ execute EXIT THEN |
dup bl < IF cells ctrlkeys + @ execute EXIT THEN |
>r 2over = IF rdrop bell 0 EXIT THEN |
>r 2over = IF rdrop bell 0 EXIT THEN |
r> (ins) 0 ; |
r> (ins) 0 ; |
|
|
Line 1203 create pathfilenamebuf 256 chars allot \
|
Line 1215 create pathfilenamebuf 256 chars allot \
|
\ DEPTH 9may93jaw |
\ DEPTH 9may93jaw |
|
|
: depth ( -- +n ) sp@ s0 @ swap - cell / ; |
: depth ( -- +n ) sp@ s0 @ swap - cell / ; |
|
: clearstack ( ... -- ) s0 @ sp! ; |
|
|
\ INCLUDE 9may93jaw |
\ INCLUDE 9may93jaw |
|
|