[gforth] / gforth / Attic / kernal.fs

# gforth: gforth/Attic/kernal.fs

### Diff for /gforth/Attic/kernal.fs between version 1.8 and 1.9

version 1.8, Fri Jun 17 12:35:07 1994 UTC version 1.9, Thu Jul 7 14:59:23 1994 UTC
 Line 79
 Line 79
\ 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
 Line 590
\ 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
\ 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
 Line 616
: 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
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 ( -- )
>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
 Line 717

: 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

 Line 777
 Line 777
: 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
 Line 1001
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
 Line 1087

\ 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

Generate output suitable for use with a patch program
Legend:
 Removed from v.1.8 changed lines Added in v.1.9