Diff for /gforth/Attic/kernal.fs between versions 1.5 and 1.13

version 1.5, 1994/05/07 14:55:58 version 1.13, 1994/07/27 13:37:02
Line 57  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 68  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 131  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 154  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 179  Create bases   10 ,   2 ,   A , 100 , Line 194  Create bases   10 ,   2 ,   A , 100 ,
 \ !! this saving and restoring base is an abomination! - anton  \ !! this saving and restoring base is an abomination! - anton
 : getbase ( addr u -- addr' u' )  over c@ [char] $ - dup 4 u<  : getbase ( addr u -- addr' u' )  over c@ [char] $ - dup 4 u<
   IF  cells bases + @ base ! 1 /string  ELSE  drop  THEN ;    IF  cells bases + @ base ! 1 /string  ELSE  drop  THEN ;
 : number?  ( string -- string 0 / n -1 )  base @ >r  : s>number ( addr len -- d )  base @ >r  dpl on
   dup count over c@ [char] - = dup >r  IF 1 /string  THEN    over c@ '- =  dup >r  IF  1 /string  THEN
   getbase  dpl on  0 0 2swap    getbase  dpl on  0 0 2swap
   BEGIN  dup >r >number dup  WHILE  dup r> -  WHILE    BEGIN  dup >r >number dup  WHILE  dup r> -  WHILE
          dup dpl ! over c@ [char] . =  WHILE           dup dpl ! over c@ [char] . =  WHILE
          1 /string           1 /string
   REPEAT  THEN  2drop 2drop rdrop false r> base ! EXIT  THEN    REPEAT  THEN  2drop rdrop dpl off  ELSE
   2drop rot drop rdrop r> IF dnegate THEN    2drop rdrop r> IF  dnegate  THEN
   dpl @ dup 0< IF  nip  THEN  r> base ! ;    THEN r> base ! ;
   : number? ( string -- string 0 / n -1 / d 0> )
     dup count s>number dpl @ 0= IF  2drop false  EXIT  THEN
     rot drop dpl @ dup 0> 0= IF  nip  THEN ;
 : s>d ( n -- d ) dup 0< ;  : s>d ( n -- d ) dup 0< ;
 : number ( string -- d )  : number ( string -- d )
   number? ?dup 0= abort" ?"  0< IF s>d THEN ;    number? ?dup 0= abort" ?"  0< IF s>d THEN ;
Line 240  hex Line 258  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
   
Line 254  hex Line 271  hex
   handler @ >r    handler @ >r
   rp@ handler !    rp@ handler !
   execute    execute
   r> handler ! rdrop rdrop 0 ;    r> handler ! rdrop rdrop rdrop 0 ;
   
 : throw ( y1 .. ym error/0 -- y1 .. ym / z1 .. zn error )  : throw ( y1 .. ym error/0 -- y1 .. ym / z1 .. zn error )
   ?DUP IF      ?DUP IF
     handler @ rp!          [ here 4 cells ! ]
     r> handler !          handler @ rp!
     r> lp!          r> handler !
     r> fp!          r> lp!
     r> swap >r sp! r>          r> fp!
   THEN ;          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 error / y1 .. ym )  : bounce ( y1 .. ym error/0 -- y1 .. ym error / y1 .. ym )
Line 286  Defer parser Line 306  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 309  Defer notfound Line 329  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
      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
 : BEGIN     here ;                           immediate restrict      POSTPONE then ; immediate restrict
 : WHILE     sys? postpone IF swap ;           immediate restrict  
 : AGAIN     sys? postpone branch  <resolve ;  immediate restrict  
 : UNTIL     sys? postpone ?branch <resolve ;  immediate restrict  : BEGIN ( -- dest )
 : REPEAT    over 0= ?struc postpone AGAIN postpone THEN ;      dead-code @ if
                                              immediate restrict          \ set up an assumption of the locals visible here
           \ currently we just take the top cs-item
 \ Structural Conditionals                              12dec92py          \ it would be more intelligent to take the top orig
           \   but that can be arranged by the user
 variable locals-size \ this is the current size of the locals stack          dup defstart <> if
                      \ frame of the current word              dup cs-item?
               2 pick
 : compile-lp+!# ( n -- )          else
     ?DUP IF              0
         dup negate locals-size +!          then
         postpone lp+!#  ,          set-locals-size-list
     THEN ;      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
   
 \ : EXIT ( -- )  : NEXT ( do-sys -- )
 \     locals-size @ compile-lp+!# POSTPONE ;s ; immediate restrict   ['] (next) ['] (next)-lp+!# loop-like ; immediate restrict
 \ : ?EXIT ( -- )  
 \     postpone IF postpone EXIT postpone THEN ; immediate restrict  
   
 Variable leavings  
   
 : (leave)   here  leavings @ ,  leavings ! ;  
 : LEAVE     postpone branch  (leave) ;  immediate restrict  
 : ?LEAVE    postpone 0= postpone ?branch  (leave) ;  
                                              immediate restrict  
 : DONE   ( addr -- )  
   leavings @  
   BEGIN  
     2dup u<=  
   WHILE  
     dup @ swap >resolve  
   REPEAT  
   leavings ! drop ;                          immediate restrict  
   
 \ Structural Conditionals                              12dec92py  \ Structural Conditionals                              12dec92py
   
 : DO        postpone (do)   here ;            immediate restrict  : EXIT ( -- )
       0 adjust-locals-size
 : ?DO       postpone (?do)  (leave) here ;      POSTPONE ;s
                                              immediate restrict      unreachable ; immediate restrict
 : FOR       postpone (for)  here ;            immediate restrict  
   
 : loop]     dup <resolve 2 cells - postpone done postpone unloop ;  
   
 : LOOP      sys? postpone (loop)  loop] ;     immediate restrict  : ?EXIT ( -- )
 : +LOOP     sys? postpone (+loop) loop] ;     immediate restrict       POSTPONE if POSTPONE exit POSTPONE then ; 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 420  Variable leavings Line 716  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 434  Variable leavings Line 732  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 459  create nextname-buffer 32 chars allot Line 759  create nextname-buffer 32 chars allot
   
 \ 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
     dup 31 u> -19 and throw ( is name too long? )      dup $1F u> -&19 and throw ( is name too long? )
     nextname-buffer c! ( c-addr )      nextname-buffer c! ( c-addr )
     nextname-buffer count move      nextname-buffer count move
     ['] nextname-header IS header ;      ['] nextname-header IS header ;
Line 482  create nextname-buffer 32 chars allot Line 782  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 557  Create ???  ," ???" Line 857  Create ???  ," ???"
   state @ IF  postpone ALiteral postpone @  ELSE  @  THEN ;    state @ IF  postpone ALiteral postpone @  ELSE  @  THEN ;
                                              immediate                                               immediate
 : Defers ( "name" -- )  ' >body @ compile, ;  : Defers ( "name" -- )  ' >body @ compile, ;
                                              immediate restrict                                               immediate
   
 \ : ;                                                  24feb93py  \ : ;                                                  24feb93py
   
 defer :-hook ( sys1 -- sys2 )  defer :-hook ( sys1 -- sys2 )
 defer ;-hook ( sys2 -- sys1 )  defer ;-hook ( sys2 -- sys1 )
   
 : EXIT  ( -- )  postpone ;s ;  immediate  : : ( -- colon-sys )  Header [ :docol ] Literal cfa, defstart ] :-hook ;
   
 : : ( -- colon-sys )  Header [ :docol ] Literal cfa, 0 ] :-hook ;  
 : ; ( colon-sys -- )  ;-hook ?struc postpone exit reveal postpone [ ;  : ; ( colon-sys -- )  ;-hook ?struc postpone exit reveal postpone [ ;
   immediate restrict    immediate restrict
   
 : :noname ( -- xt colon-sys )  here [ :docol ] Literal cfa, 0 ] :-hook ;  : :noname ( -- xt colon-sys )
       0 last !
       here [ :docol ] Literal cfa, 0 ] :-hook ;
   
 \ Search list handling                                 23feb93py  \ Search list handling                                 23feb93py
   
Line 592  AVariable current Line 892  AVariable current
   
 \ word list structure:  \ word list structure:
 \ struct  \ 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 find-method   \ xt: ( c_addr u wid -- name-id )
 \   1 cells: field reveal-method \ xt: ( -- )  \   1 cells: field reveal-method \ xt: ( -- )
   \   1 cells: field rehash-method \ xt: ( wid -- )
 \   \ !! what else  \   \ !! what else
 \ end-struct wordlist-map-struct  \ end-struct wordlist-map-struct
   
 \ struct  \ struct
 \   1 cells: field wordlist-id \ not the same as wid; representation depends on implementation  \   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-map \ pointer to a wordlist-map-struct
 \   1 cells: field ????  \   1 cells: field wordlist-link \ link field to other wordlists
 \   1 cells: field ????  \   1 cells: field wordlist-extend \ points to wordlist extensions (eg hash)
 \ end-struct wordlist-struct  \ end-struct wordlist-struct
   
   : f83find      ( addr len wordlist -- nfa / false )  @ (f83find) ;
   
 \ Search list table: find reveal  \ Search list table: find reveal
 Create f83search    ' (f83find) A,  ' (reveal) A,  Create f83search       ' f83find A,  ' (reveal) A,  ' drop 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 642  Variable warnings  G -1 warnings T ! Line 945  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 698  Create crtlkeys Line 1003  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 717  DEFER type      \ defer type for a outpu Line 1022  DEFER type      \ defer type for a outpu
 : refill ( -- flag )  : refill ( -- flag )
   tib /line    tib /line
   loadfile @ ?dup    loadfile @ ?dup
   IF    dup file-position throw linestart 2!    IF    \ dup file-position throw linestart 2!
         read-line throw          read-line throw
   ELSE  linestart @ IF 2drop false EXIT THEN    ELSE  loadline @ 0< IF 2drop false EXIT THEN
         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 753  create nl$ 1 c, A c, 0 c, \ gnu includes Line 1058  create nl$ 1 c, A c, 0 c, \ gnu includes
   
 \ include-file                                         07apr93py  \ include-file                                         07apr93py
   
 : include-file ( i*x fid -- j*x )  : push-file  ( -- )  r>
   linestart @ >r loadline @ >r loadfile @ >r    ( linestart 2@ >r >r ) loadline @ >r loadfile @ >r
   blk @ >r >tib @ >r  #tib @ dup >r  >in @ >r    blk @ >r >tib @ >r  #tib @ dup >r  >tib +!  >in @ >r  >r ;
   
   >tib +! loadfile !  : pop-file   ( -- )  r>
     r> >in !  r> #tib !  r> >tib ! r> blk !
     r> loadfile ! r> loadline ! ( r> r> linestart 2! ) >r ;
   
   : include-file ( i*x fid -- j*x )
     push-file  loadfile !
   0 loadline ! blk off    0 loadline ! blk off
   BEGIN  refill  WHILE  interpret  REPEAT    BEGIN  refill  WHILE  interpret  REPEAT
   loadfile @ close-file throw    loadfile @ close-file throw
     pop-file ;
   r> >in !  r> #tib !  r> >tib ! r> blk !  
   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 779  create nl$ 1 c, A c, 0 c, \ gnu includes Line 1093  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
   
   \ !! I think */mod should have the same rounding behaviour as / - anton
 : */mod >r m* r> sm/rem ;  : */mod >r m* r> sm/rem ;
   
 : */ */mod nip ;  : */ */mod nip ;
Line 796  create nl$ 1 c, A c, 0 c, \ gnu includes Line 1113  create nl$ 1 c, A c, 0 c, \ gnu includes
 \ EVALUATE                                              17may93jaw  \ EVALUATE                                              17may93jaw
   
 : evaluate ( c-addr len -- )  : evaluate ( c-addr len -- )
   linestart @ >r loadline @ >r loadfile @ >r    push-file  dup #tib ! >tib @ swap move
   blk @ >r >tib @ >r  #tib @ dup >r  >in @ >r    >in off blk off loadfile off -1 loadline !
   
   >tib +! dup #tib ! >tib @ swap move  
   >in off blk off loadfile off -1 linestart !  
   
   BEGIN  interpret  >in @ #tib @ u>= UNTIL    BEGIN  interpret  >in @ #tib @ u>= UNTIL
   
   r> >in !  r> #tib !  r> >tib ! r> blk !    pop-file ;
   r> loadfile ! r> loadline ! r> linestart ! ;  
   
   
 : abort -1 throw ;  : abort -1 throw ;
Line 823  Defer .status Line 1136  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 @      LoadFile @
          IF      IF
                 ." Error in line: " Loadline @ . cr          cr loadfilename 2@ type ." :" Loadline @ dec.
          THEN      THEN
          cr source type cr      cr source type cr
          source drop >in @ -trailing      source drop >in @ -trailing ( throw-code line-start index2 )
          here c@ 1F min dup >r - 1- 0 max nip      here c@ 1F min dup >r - 0 max ( throw-code line-start index1 )
          dup spaces       typewhite
          IF      r> 1 max 0 ?do \ we want at least one "^", even if the length is 0
                 ." ^"          ." ^"
          THEN      loop
          r> 0 ?DO      dup -2 =
                 ." -"       IF 
          LOOP          "error @ ?dup
          ." ^"          IF
          dup -2 =              cr count type 
          IF           THEN
                 "error @ ?dup          drop
                 IF      ELSE
                         cr count type           .error
                 THEN      THEN
                 drop      normal-dp dpp ! ;
          ELSE  
                 .error  
          THEN  
          normal-dp dpp ! ;  
   
 ' (DoError) IS DoError  ' (DoError) IS DoError
   
Line 878  Variable env Line 1203  Variable env
 Variable argv  Variable argv
 Variable argc  Variable argc
   
 : get-args ( -- )  #tib off  0 Value script? ( -- flag )
   argc @ 1 ?DO  I arg 2dup source + swap move  
                 #tib +! drop  bl source + c! 1 #tib +!  LOOP  
   >in off #tib @ 0<> #tib +! ;  
   
 : script? ( -- flag )  0 arg 1 arg dup 3 pick - /string compare 0= ;  : ">tib  ( addr len -- )  dup #tib ! >in off tib swap move ;
   
   : do-option ( addr1 len1 addr2 len2 -- n )  2swap
     2dup s" -e"        compare  0= >r
     2dup s" -evaluate" compare  0= r> or
     IF  2drop ">tib interpret  2 EXIT  THEN
     ." Unknown option: " type cr 2drop 1 ;
   
   : process-args ( -- )  argc @ 1
     ?DO  I arg over c@ [char] - <>
          IF    true to script? included  false to script? 1
          ELSE  I 1+ arg  do-option
          THEN
     +LOOP ;
   
 : cold ( -- )    : cold ( -- )  
   argc @ 1 >      argc @ 1 >
   IF  script?      IF
       IF  1 arg ['] included  ELSE   get-args ['] interpret  THEN          ['] process-args catch ?dup
       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 ;              dup >r DoError cr r> negate (bye)
           THEN
       THEN
       cr
       ." GNU Forth 0.0alpha, Copyright (C) 1994 Free Software Foundation, Inc." cr
       ." GNU Forth comes with ABSOLUTELY NO WARRANTY; for details type `license'" cr
       ." Type `bye' to exit"
       quit ;
   
   : license ( -- ) cr
    ." This program is free software; you can redistribute it and/or modify" cr
    ." it under the terms of the GNU General Public License as published by" cr
    ." the Free Software Foundation; either version 2 of the License, or" cr
    ." (at your option) any later version." cr cr
   
    ." This program is distributed in the hope that it will be useful," cr
    ." but WITHOUT ANY WARRANTY; without even the implied warranty of" cr
    ." MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the" cr
    ." GNU General Public License for more details." cr cr
   
    ." You should have received a copy of the GNU General Public License" cr
    ." along with this program; if not, write to the Free Software" cr
    ." Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA." cr ;
   
 : boot ( **env **argv argc -- )  : boot ( **env **argv argc -- )
   argc ! argv ! env !  main-task up!    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  script? 0= IF  cr  THEN  0 (bye) ;
   
 \ **argv may be scanned by the C starter to get some important  \ **argv may be scanned by the C starter to get some important
 \ information, as -display and -geometry for an X client FORTH  \ information, as -display and -geometry for an X client FORTH

Removed from v.1.5  
changed lines
  Added in v.1.13


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