Diff for /gforth/Attic/kernal.fs between versions 1.3 and 1.10

version 1.3, 1994/05/03 15:24:12 version 1.10, 1994/07/08 15:00:51
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 56  DOES> ( n -- )  + c@ ; Line 57  DOES> ( n -- )  + c@ ;
   [ cell 1- ] Literal + [ -1 cells ] Literal and ;    [ cell 1- ] Literal + [ -1 cells ] Literal and ;
 : align ( -- )          here dup aligned swap ?DO  bl c,  LOOP ;  : align ( -- )          here dup aligned swap ?DO  bl c,  LOOP ;
   
   : faligned ( addr -- f-addr )
     [ 1 floats 1- ] Literal + [ -1 floats ] Literal and ;
   
   : falign ( -- )
     here dup faligned swap
     ?DO
         bl c,
     LOOP ;
   
   
   
 : A!    ( addr1 addr2 -- )  dup relon ! ;  : A!    ( addr1 addr2 -- )  dup relon ! ;
 : A,    ( addr -- )     here cell allot A! ;  : A,    ( addr -- )     here cell allot A! ;
   
Line 67  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 130  Defer source Line 142  Defer source
   dup count chars bounds    dup count chars bounds
   ?DO  I c@ toupper I c! 1 chars +LOOP ;    ?DO  I c@ toupper I c! 1 chars +LOOP ;
 : (name)  ( -- addr )  bl word ;  : (name)  ( -- addr )  bl word ;
   : (cname) ( -- addr )  bl word capitalize ;
   
 \ Literal                                              17dec92py  \ Literal                                              17dec92py
   
 : Literal  ( n -- )  state @ 0= ?EXIT  postpone lit  , ;  : Literal  ( n -- )  state @ IF postpone lit  , THEN ;
                                                       immediate                                                        immediate
 : ALiteral ( n -- )  state @ 0= ?EXIT  postpone lit A, ;  : ALiteral ( n -- )  state @ IF postpone lit A, THEN ;
                                                       immediate                                                        immediate
   
 : char   ( 'char' -- n )  bl word char+ c@ ;  : char   ( 'char' -- n )  bl word char+ c@ ;
Line 153  Defer source Line 166  Defer source
 \ digit?                                               17dec92py  \ digit?                                               17dec92py
   
 : digit?   ( char -- digit true/ false )  : digit?   ( char -- digit true/ false )
   base @ $100 = ?dup ?EXIT    base @ $100 =
     IF
       true EXIT
     THEN
   toupper [char] 0 - dup 9 u> IF    toupper [char] 0 - dup 9 u> IF
     [ 'A '9 1 + -  ] literal -      [ 'A '9 1 + -  ] literal -
     dup 9 u<= IF      dup 9 u<= IF
Line 239  hex Line 255  hex
 \ catch throw                                          23feb93py  \ catch throw                                          23feb93py
 \ bounce                                                08jun93jaw  \ bounce                                                08jun93jaw
   
 \ !! what about the other stacks (FP, locals)  anton  
 \ !! 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 rdrop 0 ;
   
   : throw ( y1 .. ym error/0 -- y1 .. ym / z1 .. zn error )
       ?DUP IF
           [ here 4 cells ! ]
           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 291  Defer notfound Line 326  Defer notfound
 : [     ['] interpreter  IS parser state off ; immediate  : [     ['] interpreter  IS parser state off ; immediate
 : ]     ['] compiler     IS parser state on  ;  : ]     ['] compiler     IS parser state on  ;
   
   \ locals stuff needed for control structures
   
   : compile-lp+! ( n -- )
       dup negate locals-size +!
       0 over = if
       else -4 over = if postpone -4lp+!
       else  8 over = if postpone  8lp+!
       else 16 over = if postpone 16lp+!
       else postpone lp+!# dup ,
       then then then then drop ;
   
   : adjust-locals-size ( n -- )
       \ sets locals-size to n and generates an appropriate lp+!
       locals-size @ swap - compile-lp+! ;
   
   
   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
                         \ a linear list of locals names
   
   
   variable dead-code \ true if normal code at "here" would be dead
   
   : unreachable ( -- )
   \ declares the current point of execution as unreachable
    dead-code on ;
   
   \ locals list operations
   
   : common-list ( list1 list2 -- list3 )
   \ list1 and list2 are lists, where the heads are at higher addresses than
   \ the tail. list3 is the largest sublist of both lists.
    begin
      2dup u<>
    while
      2dup u>
      if
        swap
      then
      @
    repeat
    drop ;
   
   : sub-list? ( list1 list2 -- f )
   \ true iff list1 is a sublist of list2
    begin
      2dup u<
    while
      @
    repeat
    = ;
   
   : list-size ( list -- u )
   \ size of the locals frame represented by list
    0 ( list n )
    begin
      over 0<>
    while
      over
      cell+ name> >body @ max
      swap @ swap ( get next )
    repeat
    faligned nip ;
   
   : set-locals-size-list ( list -- )
    dup locals-list !
    list-size locals-size ! ;
   
   : check-begin ( list -- )
   \ warn if list is not a sublist of locals-list
    locals-list @ sub-list? 0= if
      \ !! print current position
      ." compiler was overly optimistic about locals at a BEGIN" cr
      \ !! print assumption and reality
    then ;
   
   \ Control Flow Stack
   \ orig, etc. have the following structure:
   \ type ( defstart, live-orig, dead-orig, dest, do-dest, scopestart) ( TOS )
   \ address (of the branch or the instruction to be branched to) (second)
   \ locals-list (valid at address) (third)
   
   \ types
   0 constant defstart
   1 constant live-orig
   2 constant dead-orig
   3 constant dest \ the loopback branch is always assumed live
   4 constant do-dest
   5 constant scopestart
   
   : def? ( n -- )
       defstart <> abort" unstructured " ;
   
   : orig? ( n -- )
    dup live-orig <> swap dead-orig <> and abort" expected orig " ;
   
   : dest? ( n -- )
    dest <> abort" expected dest " ;
   
   : do-dest? ( n -- )
    do-dest <> abort" expected do-dest " ;
   
   : scope? ( n -- )
    scopestart <> abort" expected scope " ;
   
   : non-orig? ( n -- )
    dest scopestart 1+ within 0= abort" expected dest, do-dest or scope" ;
   
   : cs-item? ( n -- )
    live-orig scopestart 1+ within 0= abort" expected control flow stack item" ;
   
   3 constant cs-item-size
   
   : CS-PICK ( ... u -- ... destu )
    1+ cs-item-size * 1- >r
    r@ pick  r@ pick  r@ pick
    rdrop
    dup non-orig? ;
   
   : CS-ROLL ( destu/origu .. dest0/orig0 u -- .. dest0/orig0 destu/origu )
    1+ cs-item-size * 1- >r
    r@ roll r@ roll r@ roll
    rdrop
    dup cs-item? ; 
   
   : cs-push-part ( -- list addr )
    locals-list @ here ;
   
   : cs-push-orig ( -- orig )
    cs-push-part dead-code @
    if
      dead-orig
    else
      live-orig
    then ;   
   
 \ Structural Conditionals                              12dec92py  \ Structural Conditionals                              12dec92py
   
 : ?struc      ( flag -- )       abort" unstructured " ;  : ?struc      ( flag -- )       abort" unstructured " ;
 : sys?        ( sys -- )        dup 0= ?struc ;  : sys?        ( sys -- )        dup 0= ?struc ;
 : >mark       ( -- sys )        here  0 , ;  : >mark ( -- orig )
 : >resolve    ( sys -- )        here over - swap ! ;   cs-push-orig 0 , ;
 : <resolve    ( sys -- )        here - , ;  : >resolve    ( addr -- )        here over - swap ! ;
   : <resolve    ( addr -- )        here - , ;
   
 : BUT       sys? swap ;                      immediate restrict  : BUT       1 cs-roll ;                      immediate restrict
 : YET       sys? dup ;                       immediate restrict  : YET       0 cs-pick ;                       immediate restrict
   
 \ Structural Conditionals                              12dec92py  \ Structural Conditionals                              12dec92py
   
 : AHEAD     postpone branch >mark ;           immediate restrict  : AHEAD ( -- orig )
 : IF        postpone ?branch >mark ;          immediate restrict   POSTPONE branch >mark unreachable ; immediate restrict
   
   : IF ( -- orig )
    POSTPONE ?branch >mark ; immediate restrict
   
 : ?DUP-IF \ general  : ?DUP-IF \ general
 \ This is the preferred alternative to the idiom "?DUP IF", since it can be  \ This is the preferred alternative to the idiom "?DUP IF", since it can be
 \ better handled by tools like stack checkers  \ better handled by tools like stack checkers
     postpone ?dup postpone IF ;       immediate restrict      POSTPONE ?dup POSTPONE if ;       immediate restrict
 : ?DUP-NOT-IF \ general  : ?DUP-NOT-IF \ general
     postpone ?dup postpone 0= postpone if ; immediate restrict      POSTPONE ?dup POSTPONE 0= POSTPONE if ; immediate restrict
 : THEN      sys? dup @ ?struc >resolve ;     immediate restrict  
   : THEN ( orig -- )
       dup orig?
       dead-code @
       if
           dead-orig =
           if
               >resolve drop
           else
               >resolve set-locals-size-list dead-code off
           then
       else
           dead-orig =
           if
               >resolve drop
           else \ both live
               over list-size adjust-locals-size
               >resolve
               locals-list @ common-list dup list-size adjust-locals-size
               locals-list !
           then
       then ; immediate restrict
   
 ' THEN alias ENDIF immediate restrict \ general  ' THEN alias ENDIF immediate restrict \ general
 \ Same as "THEN". This is what you use if your program will be seen by  \ Same as "THEN". This is what you use if your program will be seen by
 \ people who have not been brought up with Forth (or who have been  \ people who have not been brought up with Forth (or who have been
 \ brought up with fig-Forth).  \ brought up with fig-Forth).
   
 : ELSE      sys? postpone AHEAD swap postpone THEN ;  : ELSE ( orig1 -- orig2 )
                                              immediate restrict      POSTPONE ahead
       1 cs-roll
       POSTPONE then ; immediate restrict
   
   
   : BEGIN ( -- dest )
       dead-code @ if
           \ set up an assumption of the locals visible here
           \ currently we just take the top cs-item
           \ it would be more intelligent to take the top orig
           \   but that can be arranged by the user
           dup defstart <> if
               dup cs-item?
               2 pick
           else
               0
           then
           set-locals-size-list
       then
       cs-push-part dest
       dead-code off ; immediate restrict
   
   \ AGAIN (the current control flow joins another, earlier one):
   \ If the dest-locals-list is not a subset of the current locals-list,
   \ issue a warning (see below). The following code is generated:
   \ lp+!# (current-local-size - dest-locals-size)
   \ branch <begin>
   : AGAIN ( dest -- )
       dest?
       over list-size adjust-locals-size
       POSTPONE branch
       <resolve
       check-begin
       unreachable ; immediate restrict
   
   \ 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
   \ ones. The following code is generated:
   \ ?branch-lp+!# <begin> (current-local-size - dest-locals-size)
   : until-like ( list addr xt1 xt2 -- )
       \ list and addr are a fragment of a cs-item
       \ xt1 is the conditional branch without lp adjustment, xt2 is with
       >r >r
       locals-size @ 2 pick list-size - dup if ( list dest-addr adjustment )
           r> drop r> compile,
           swap <resolve ( list adjustment ) ,
       else ( list dest-addr adjustment )
           drop
           r> compile, <resolve
           r> drop
       then ( list )
       check-begin ;
   
   : UNTIL ( dest -- )
       dest? ['] ?branch ['] ?branch-lp+!# until-like ; immediate restrict
   
   : WHILE ( dest -- orig dest )
       POSTPONE if
       1 cs-roll ; immediate restrict
   
   : REPEAT ( orig dest -- )
       POSTPONE again
       POSTPONE then ; immediate restrict
   
   
   \ counted loops
   
   \ leave poses a little problem here
   \ we have to store more than just the address of the branch, so the
   \ traditional linked list approach is no longer viable.
   \ This is solved by storing the information about the leavings in a
   \ special stack.
   
   \ !! remove the fixed size limit. 'Tis not hard.
   20 constant leave-stack-size
   create leave-stack  60 cells allot
   Avariable leave-sp  leave-stack 3 cells + leave-sp !
   
   : clear-leave-stack ( -- )
       leave-stack leave-sp ! ;
   
   \ : leave-empty? ( -- f )
   \  leave-sp @ leave-stack = ;
   
   : >leave ( orig -- )
       \ push on leave-stack
       leave-sp @
       dup [ leave-stack 60 cells + ] Aliteral
       >= abort" leave-stack full"
       tuck ! cell+
       tuck ! cell+
       tuck ! cell+
       leave-sp ! ;
   
   : leave> ( -- orig )
       \ pop from leave-stack
       leave-sp @
       dup leave-stack <= IF
          drop 0 0 0  EXIT  THEN
       cell - dup @ swap
       cell - dup @ swap
       cell - dup @ swap
       leave-sp ! ;
   
   : DONE ( orig -- )  drop >r drop
       \ !! the original done had ( addr -- )
       begin
           leave>
           over r@ u>=
       while
           POSTPONE then
       repeat
       >leave rdrop ; immediate restrict
   
   : LEAVE ( -- )
       POSTPONE ahead
       >leave ; immediate restrict
   
   : ?LEAVE ( -- )
       POSTPONE 0= POSTPONE if
       >leave ; immediate restrict
   
   : DO ( -- do-sys )
       POSTPONE (do)
       POSTPONE begin drop do-dest
       ( 0 0 0 >leave ) ; immediate restrict
   
   : ?DO ( -- do-sys )
       ( 0 0 0 >leave )
       POSTPONE (?do)
       >mark >leave
       POSTPONE begin drop do-dest ; immediate restrict
   
   : FOR ( -- do-sys )
       POSTPONE (for)
       POSTPONE begin drop do-dest
       ( 0 0 0 >leave ) ; immediate restrict
   
   \ LOOP etc. are just like UNTIL
   
   : loop-like ( do-sys xt1 xt2 -- )
       >r >r 0 cs-pick swap cell - swap 1 cs-roll r> r> rot do-dest?
       until-like  POSTPONE done  POSTPONE unloop ;
   
   : LOOP ( do-sys -- )
    ['] (loop) ['] (loop)-lp+!# loop-like ; immediate restrict
   
   : +LOOP ( do-sys -- )
    ['] (+loop) ['] (+loop)-lp+!# loop-like ; immediate restrict
   
   \ 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
   \ increments it behaves like "+LOOP". Use S+LOOP instead of +LOOP for
   \ negative increments.
   : S+LOOP ( do-sys -- )
    ['] (s+loop) ['] (s+loop)-lp+!# loop-like ; immediate restrict
   
 : BEGIN     here ;                           immediate restrict  : NEXT ( do-sys -- )
 : WHILE     sys? postpone IF swap ;           immediate restrict   ['] (next) ['] (next)-lp+!# loop-like ; immediate restrict
 : AGAIN     sys? postpone branch  <resolve ;  immediate restrict  
 : UNTIL     sys? postpone ?branch <resolve ;  immediate restrict  
 : REPEAT    over 0= ?struc postpone AGAIN postpone THEN ;  
                                              immediate restrict  
   
 \ Structural Conditionals                              12dec92py  \ Structural Conditionals                              12dec92py
   
 Variable leavings  : EXIT ( -- )
       0 adjust-locals-size
 : (leave)   here  leavings @ ,  leavings ! ;      POSTPONE ;s
 : LEAVE     postpone branch  (leave) ;  immediate restrict      unreachable ; immediate restrict
 : ?LEAVE    postpone 0= postpone ?branch  (leave) ;  
                                              immediate restrict  
   
 : DONE   ( addr -- )  leavings @  : ?EXIT ( -- )
   BEGIN  2dup u<=  WHILE  dup @ swap >resolve  REPEAT       POSTPONE if POSTPONE exit POSTPONE then ; immediate restrict
   leavings ! drop ;                          immediate restrict  
   
 \ Structural Conditionals                              12dec92py  
   
 : DO        postpone (do)   here ;            immediate restrict  
   
 : ?DO       postpone (?do)  (leave) here ;  
                                              immediate restrict  
 : FOR       postpone (for)  here ;            immediate restrict  
   
 : loop]     dup <resolve 2 cells - postpone done postpone unloop ;  
   
 : LOOP      sys? postpone (loop)  loop] ;     immediate restrict  
 : +LOOP     sys? postpone (+loop) loop] ;     immediate restrict  
 : S+LOOP \ general  
 \ 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 increments it behaves like "+LOOP". Use S+LOOP instead of +LOOP for negative increments.  
     sys? postpone (s+loop) loop] ;    immediate restrict  
 : NEXT      sys? postpone (next)  loop] ;     immediate restrict  
   
 \ Strings                                              22feb93py  \ Strings                                              22feb93py
   
Line 384  Variable leavings Line 713  Variable leavings
   
 \ 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
   
 \ Header                                               23feb93py  \ Header                                               23feb93py
   
Line 398  Variable leavings Line 729  Variable leavings
 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 411  defer header Line 744  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 756  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 $1F 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 444  create nextname-string 2 cells allot \ s Line 779  create nextname-string 2 cells allot \ s
 : 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 466  Create ???  ," ???" Line 801  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 824  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  
   Create 2, DOES> 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 858  Create ???  ," ???"
   
 \ : ;                                                  24feb93py  \ : ;                                                  24feb93py
   
 : EXIT  ( -- )  postpone ;s ;  immediate  defer :-hook ( sys1 -- sys2 )
   defer ;-hook ( sys2 -- sys1 )
   
 : : ( -- colon-sys )  Header [ :docol ] ALiteral cfa, 0 ] ;  : : ( -- colon-sys )  Header [ :docol ] Literal cfa, defstart ] :-hook ;
 : ; ( colon-sys -- )  ?struc postpone exit reveal postpone [ ;  : ; ( colon-sys -- )  ;-hook ?struc postpone exit reveal postpone [ ;
   immediate restrict    immediate restrict
 : :noname ( -- xt colon-sys )  here [ ' : @ ] ALiteral cfa, 0 ] ;  
   : :noname ( -- xt colon-sys )
       0 last !
       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
   
   \ word list structure:
   \ struct
   \   1 cells: field find-method   \ xt: ( c_addr u wid -- name-id )
   \   1 cells: field reveal-method \ xt: ( -- )
   \   1 cells: field rehash-method \ xt: ( wid -- )
   \   \ !! 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 wordlist-link \ link field to other wordlists
   \   1 cells: field wordlist-extend \ points to wordlist extensions (eg hash)
   \ end-struct wordlist-struct
   
   : f83find      ( addr len wordlist -- nfa / false )  @ (f83find) ;
   : f83casefind  ( addr len wordlist -- nfa / false )  @ (f83casefind) ;
   
 \ Search list table: find reveal  \ Search list table: find reveal
   Create f83search       ' f83casefind A,  ' (reveal) A,  ' drop A,
   
   : caps-name       ['] (cname) IS name  ['] f83find     f83search ! ;
   : case-name       ['] (name)  IS name  ['] f83casefind f83search ! ;
   : case-sensitive  ['] (name)  IS name  ['] f83find     f83search ! ;
   
 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 !
 G forth-wordlist current T !  G forth-wordlist current T !
   
 : (search-wordlist)  ( addr count wid -- nfa / false )  : (search-wordlist)  ( addr count wid -- nfa / false )
   dup @ swap cell+ @ @ execute ;    dup ( @ swap ) cell+ @ @ execute ;
   
 : search-wordlist  ( addr count wid -- 0 / xt +-1 )  : search-wordlist  ( addr count wid -- 0 / xt +-1 )
   (search-wordlist) dup  IF  found  THEN ;    (search-wordlist) dup  IF  found  THEN ;
Line 566  Variable warnings  G -1 warnings T ! Line 947  Variable warnings  G -1 warnings T !
  then   then
  current @ cell+ @ cell+ @ execute ;   current @ cell+ @ cell+ @ execute ;
   
   : rehash  ( wid -- )  dup cell+ @ cell+ cell+ @ execute ;
   
 : '    ( "name" -- addr )  name find 0= no.extensions ;  : '    ( "name" -- addr )  name find 0= no.extensions ;
 : [']  ( "name" -- addr )  ' postpone ALiteral ; immediate  : [']  ( "name" -- addr )  ' postpone ALiteral ; immediate
 \ Input                                                13feb93py  \ Input                                                13feb93py
Line 622  Create crtlkeys Line 1005  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 647  DEFER type      \ defer type for a outpu Line 1030  DEFER type      \ defer type for a outpu
         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 690  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 703  create nl$ 1 c, A c, 0 c, \ gnu includes Line 1092  create nl$ 1 c, A c, 0 c, \ gnu includes
   
 \ INCLUDE                                               9may93jaw  \ INCLUDE                                               9may93jaw
   
 : include  : include  ( "file" -- )
         bl word count included ;    bl word count included ;
   
 \ 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 747  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 @ IF ." Error in line: " Loadline @ . cr THEN      LoadFile @
          cr source type cr      IF
          source drop >in @ -trailing          cr loadfilename 2@ type ." :" Loadline @ dec.
          here c@ 1F min dup >r - 1- 0 max nip      THEN
          dup spaces IF ." ^" THEN r> 0 ?DO ." -" LOOP ." ^"      cr source type cr
          dup -2 =      source drop >in @ -trailing ( throw-code line-start index2 )
          IF "error @ ?dup IF cr count type THEN drop      here c@ 1F min dup >r - 0 max ( throw-code line-start index1 )
          ELSE .error THEN ;      typewhite
       r> 1 max 0 ?do \ we want at least one "^", even if the length is 0
           ." ^"
       loop
       dup -2 =
       IF 
           "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 787  Variable argc Line 1212  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 ( -- )  
   IF  script?      argc @ 1 >
       IF  1 arg ['] included  ELSE   get-args ['] interpret  THEN      IF  script?
       catch ?dup IF  dup >r DoError cr r> (bye)  THEN THEN          IF
   ." ANS FORTH-93 (c) 1993 by the ANS FORTH-93 Team" cr quit ;              1 arg ['] included
           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 !    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) ;

Removed from v.1.3  
changed lines
  Added in v.1.10


FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>