Diff for /gforth/Attic/kernal.fs between versions 1.7 and 1.40

version 1.7, 1994/06/01 10:05:18 version 1.40, 1995/09/06 21:00:21
Line 1 Line 1
 \ KERNAL.FS    ANS figFORTH kernal                     17dec92py  \ KERNAL.FS    GNU FORTH kernal                        17dec92py
 \ $ID:  \ $ID:
 \ Idea and implementation: Bernd Paysan (py)  \ Idea and implementation: Bernd Paysan (py)
 \ Copyright 1992 by the ANSI figForth Development Group  \ Copyright 1992 by the ANSI figForth Development Group
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 ;
   
   \ !! this is machine-dependent, but works on all but the strangest machines
   ' faligned Alias maxaligned
   ' falign Alias maxalign
   
   \ the code field is aligned if its body is maxaligned
   \ !! machine-dependent and won't work if "0 >body" <> "0 >body maxaligned"
   ' maxaligned Alias cfaligned
   ' maxalign Alias cfalign
   
   : 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 67  DOES> ( n -- )  + c@ ; Line 87  DOES> ( n -- )  + c@ ;
   
 \ name> found                                          17dec92py  \ name> found                                          17dec92py
   
 : (name>)  ( nfa -- cfa )    count  $1F and  +  aligned ;  : (name>)  ( nfa -- cfa )
       count  $1F and  +  cfaligned ;
 : name>    ( nfa -- cfa )  : name>    ( nfa -- cfa )
   dup  (name>) swap  c@ $80 and 0= IF  @ THEN ;      cell+
       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 99  Defer source Line 121  Defer source
   
 \ (word)                                               22feb93py  \ (word)                                               22feb93py
   
 : scan   ( addr1 n1 char -- addr2 n2 )  >r  : scan   ( addr1 n1 char -- addr2 n2 )
   BEGIN  dup  WHILE  over c@ r@ <>  WHILE  1 /string      \ skip all characters not equal to char
   REPEAT  THEN  rdrop ;      >r
 : skip   ( addr1 n1 char -- addr2 n2 )  >r      BEGIN
   BEGIN  dup  WHILE  over c@ r@  =  WHILE  1 /string          dup
   REPEAT  THEN  rdrop ;      WHILE
           over c@ r@ <>
       WHILE
           1 /string
       REPEAT  THEN
       rdrop ;
   : skip   ( addr1 n1 char -- addr2 n2 )
       \ skip all characters equal to char
       >r
       BEGIN
           dup
       WHILE
           over c@ r@  =
       WHILE
           1 /string
       REPEAT  THEN
       rdrop ;
   
 : (word) ( addr1 n1 char -- addr2 n2 )  : (word) ( addr1 n1 char -- addr2 n2 )
   dup >r skip 2dup r> scan  nip - ;    dup >r skip 2dup r> scan  nip - ;
Line 115  Defer source Line 153  Defer source
 \ word parse                                           23feb93py  \ word parse                                           23feb93py
   
 : parse-word  ( char -- addr len )  : parse-word  ( char -- addr len )
   source 2dup >r >r >in @ /string    source 2dup >r >r >in @ over min /string
   rot dup bl = IF  drop (parse-white)  ELSE  (word)  THEN    rot dup bl = IF  drop (parse-white)  ELSE  (word)  THEN
   2dup + r> - 1+ r> min >in ! ;    2dup + r> - 1+ r> min >in ! ;
 : word   ( char -- addr )  : word   ( char -- addr )
   parse-word here place  bl here count + c!  here ;    parse-word here place  bl here count + c!  here ;
   
 : parse    ( char -- addr len )  : parse    ( char -- addr len )
   >r  source  >in @ /string  over  swap r>  scan >r    >r  source  >in @ over min /string  over  swap r>  scan >r
   over - dup r> IF 1+ THEN  >in +! ;    over - dup r> IF 1+ THEN  >in +! ;
   
 \ name                                                 13feb93py  \ name                                                 13feb93py
   
 : capitalize ( addr -- addr )  : capitalize ( addr len -- addr len )
   dup count chars bounds    2dup chars 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) ( -- c-addr count )
 : (cname) ( -- addr )  bl word capitalize ;      source 2dup >r >r >in @ /string (parse-white)
       2dup + r> - 1+ r> min >in ! ;
   \    name count ;
   
   : name-too-short? ( c-addr u -- c-addr u )
       dup 0= -&16 and throw ;
   
   : name-too-long? ( c-addr u -- c-addr u )
       dup $1F u> -&19 and throw ;
   
 \ 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@ ;
 : [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 find 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 155  Defer source Line 201  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 180  Create bases   10 ,   2 ,   A , 100 , Line 229  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 ! ;
   : snumber? ( c-addr u -- 0 / n -1 / d 0> )
       s>number dpl @ 0=
       IF
           2drop false  EXIT
       THEN
       dpl @ dup 0> 0= IF
           nip
       THEN ;
   : number? ( string -- string 0 / n -1 / d 0> )
       dup >r count snumber? dup if
           rdrop
       else
           r> swap
       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 198  decimal Line 261  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 241  hex Line 307  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 258  hex Line 323  hex
   r> handler ! rdrop 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
Line 280  hex Line 346  hex
   
 \ ?stack                                               23feb93py  \ ?stack                                               23feb93py
   
 : ?stack ( ?? -- ?? )  sp@ s0 @ > IF  -4 throw  THEN ;  : ?stack ( ?? -- ?? )
       sp@ s0 @ > IF    -4 throw  THEN
       fp@ f0 @ > IF  -&45 throw  THEN  ;
 \ ?stack should be code -- it touches an empty stack!  \ ?stack should be code -- it touches an empty stack!
   
 \ interpret                                            10mar92py  \ interpret                                            10mar92py
   
 Defer parser  Defer parser
 Defer name      ' (name) IS name  Defer name      ' (name) IS name
 Defer notfound  Defer notfound ( c-addr count -- )
   
 : no.extensions  ( string -- )  IF  &-13 bounce  THEN ;  : no.extensions  ( addr u -- )  2drop -&13 bounce ;
   
 ' no.extensions IS notfound  ' no.extensions IS notfound
   
 : interpret  : interpret
   BEGIN  ?stack name dup c@  WHILE  parser  REPEAT drop ;      BEGIN
           ?stack name dup
       WHILE
           parser
       REPEAT
       2drop ;
   
 \ interpreter compiler                                 30apr92py  \ interpreter compiler                                 30apr92py
   
 : interpreter  ( name -- ) find ?dup  : interpreter  ( c-addr u -- ) 
   IF  1 and  IF execute  EXIT THEN  -&14 throw  THEN      \ interpretation semantics for the name/number c-addr u
   number? 0= IF  notfound THEN ;      2dup sfind dup
       IF
           1 and
           IF \ not restricted to compile state?
               nip nip execute EXIT
           THEN
           -&14 throw
       THEN
       drop
       2dup 2>r snumber?
       IF
           2rdrop
       ELSE
           2r> notfound
       THEN ;
   
 ' interpreter  IS  parser  ' interpreter  IS  parser
   
 : compiler     ( name -- ) find  ?dup  : compiler     ( c-addr u -- )
   IF  0> IF  execute EXIT THEN compile, EXIT THEN number? dup      \ compilation semantics for the name/number c-addr u
   IF  0> IF  swap postpone Literal  THEN  postpone Literal      2dup sfind dup
   ELSE  drop notfound  THEN ;      IF
           0>
           IF
               nip nip execute EXIT
           THEN
           compile, 2drop EXIT
       THEN
       drop
       2dup snumber? dup
       IF
           0>
           IF
               swap postpone Literal
           THEN
           postpone Literal
           2drop
       ELSE
           drop notfound
       THEN ;
   
 : [     ['] 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 -1 cells  over = if postpone lp-
       else  1 floats over = if postpone lp+
       else  2 floats over = if postpone lp+2
       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
   variable backedge-locals
       \ contains the locals list that BEGIN will assume to be live on
       \ the back edge if the BEGIN is unreachable from above. Set by
       \ 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
   
   : 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 POSTPONE 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-0=-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-orig =
       if
           >resolve drop
       else
           dead-code @
           if
               >resolve set-locals-size-list dead-code off
           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.  if the
           \ users want something to be visible, they have to declare
           \ that using ASSUME-LIVE
           backedge-locals @ 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
       POSTPONE 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 -- )
       \ !! the original done had ( addr -- )
       drop >r drop
       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 locals-size \ this is the current size of the locals stack  : EXIT ( -- )
                      \ frame of the current word      0 adjust-locals-size
       POSTPONE ;s
 : compile-lp+!# ( n -- )      POSTPONE unreachable ; immediate restrict
     ?DUP IF  
         dup negate locals-size +!  
         postpone lp+!#  ,  
     THEN ;  
   
 \ : EXIT ( -- )  : ?EXIT ( -- )
 \     locals-size @ compile-lp+!# POSTPONE ;s ; immediate restrict       POSTPONE if POSTPONE exit POSTPONE then ; 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  
   
 : 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 407  Variable leavings Line 789  Variable leavings
 : (S")     "lit count ;                                restrict  : (S")     "lit count ;                                restrict
 : SLiteral postpone (S") here over char+ allot  place align ;  : SLiteral postpone (S") here over char+ allot  place align ;
                                              immediate restrict                                               immediate restrict
 : S"       [char] " parse  state @ IF  postpone SLiteral  THEN ;  create s"-buffer /line chars allot
   : S" ( run-time: -- c-addr u )
       [char] " parse
       state @
       IF
           postpone SLiteral
       ELSE
           /line min >r s"-buffer r@ cmove
           s"-buffer r>
       THEN ;
                                              immediate                                               immediate
 : ."       state @  IF    postpone (.") ,"  align  : ."       state @  IF    postpone (.") ,"  align
                     ELSE  [char] " parse type  THEN  ;  immediate                      ELSE  [char] " parse type  THEN  ;  immediate
 : (        [char] ) parse 2drop ;                       immediate  : (        [char] ) parse 2drop ;                       immediate
 : \        source >in ! drop ;                          immediate  : \ ( -- ) \ core-ext backslash
       blk @
       IF
           >in @ c/l / 1+ c/l * >in !
           EXIT
       THEN
       source >in ! drop ; immediate
   
   : \G ( -- ) \ new backslash
       POSTPONE \ ; immediate
   
 \ error handling                                       22feb93py  \ error handling                                       22feb93py
 \ 'abort thrown out!                                   11may93jaw  \ 'abort thrown out!                                   11may93jaw
Line 423  Variable leavings Line 823  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 836  Variable leavings
 \ information through global variables), but they are useful for dealing  \ information through global variables), but they are useful for dealing
 \ with existing/independent defining words  \ with existing/independent defining words
   
 defer header  defer (header)
   defer header     ' (header) IS header
   
   : string, ( c-addr u -- )
       \ puts down string as cstring
       dup c, here swap chars dup allot move ;
   
 : name,  ( "name" -- )  : name,  ( "name" -- )
     name c@ 1+ chars allot align ;      name name-too-short? name-too-long?
       string, cfalign ;
 : 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 445  defer header Line 853  defer header
   
 : input-stream ( -- )  \ general  : input-stream ( -- )  \ general
 \ switches back to getting the name from the input stream ;  \ switches back to getting the name from the input stream ;
     ['] input-stream-header IS header ;      ['] input-stream-header IS (header) ;
   
 ' input-stream-header IS header  ' input-stream-header IS (header)
   
 \ !! make that a 2variable  \ !! make that a 2variable
 create nextname-buffer 32 chars allot  create nextname-buffer 32 chars allot
Line 456  create nextname-buffer 32 chars allot Line 864  create nextname-buffer 32 chars allot
     \ !! f83-implementation-dependent      \ !! f83-implementation-dependent
     nextname-buffer count      nextname-buffer count
     align here last ! -1 A,      align here last ! -1 A,
     dup c,  here swap chars  dup allot  move  align      string, cfalign
     $80 flag!      $80 flag!
     input-stream ;      input-stream ;
   
 \ 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? )      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) ;
   
 : noname-header ( -- )  : noname-header ( -- )
     0 last !      0 last ! cfalign
     input-stream ;      input-stream ;
   
 : noname ( -- ) \ general  : noname ( -- ) \ general
 \ the next defined word remains anonymous. The xt of that word is given by lastxt  \ the next defined word remains anonymous. The xt of that word is given by lastxt
     ['] noname-header IS header ;      ['] noname-header IS (header) ;
   
 : lastxt ( -- xt ) \ general  : lastxt ( -- xt ) \ general
 \ xt is the execution token of the last word defined. The main purpose of this word is to get the xt of words defined using noname  \ xt is the execution token of the last word defined. The main purpose of this word is to get the xt of words defined using noname
Line 485  create nextname-buffer 32 chars allot Line 893  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 + cfaligned over $80 + = if
      i - cell - unloop exit       i - cell - unloop exit
    then     then
  cell +loop   cell +loop
Line 534  Create ???  ," ???" Line 942  Create ???  ," ???"
 : Constant  (Constant) , ;  : Constant  (Constant) , ;
 : AConstant (Constant) A, ;  : AConstant (Constant) A, ;
   
 : 2CONSTANT  : 2Constant
     create ( w1 w2 "name" -- )      Create ( w1 w2 "name" -- )
         2,          2,
     does> ( -- w1 w2 )      DOES> ( -- w1 w2 )
         2@ ;          2@ ;
           
 \ IS Defer What's Defers TO                            24feb93py  \ IS Defer What's Defers TO                            24feb93py
   
 : Defer  : Defer ( -- )
   Create ( -- )       \ !! shouldn't it be initialized with abort or something similar?
     ['] noop A,      Header Reveal [ :dodefer ] Literal cfa,
   DOES> ( ??? )      ['] noop A, ;
     @ execute ;  \     Create ( -- ) 
   \       ['] noop A,
   \     DOES> ( ??? )
   \       @ execute ;
   
 : IS ( addr "name" -- )  : IS ( addr "name" -- )
     ' >body      ' >body
Line 560  Create ???  ," ???" Line 971  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 581  AVariable current Line 992  AVariable current
   
 : last?   ( -- false / nfa nfa )    last @ ?dup ;  : last?   ( -- false / nfa nfa )    last @ ?dup ;
 : (reveal) ( -- )  : (reveal) ( -- )
   last?      last?
   IF      IF
       dup @ 0<          dup @ 0<
       IF          IF
         current @ @ over ! current @ !              current @ @ over ! current @ !
       ELSE          ELSE
         drop              drop
       THEN          THEN
   THEN ;      THEN ;
   
 \ object oriented search list                          17mar93py  \ object oriented search list                          17mar93py
   
 \ word list structure:  \ word list structure:
 \ struct  
 \   1 cells: field find-method   \ xt: ( c_addr u wid -- name-id )  struct
 \   1 cells: field reveal-method \ xt: ( -- )    1 cells: field find-method   \ xt: ( c_addr u wid -- name-id )
 \   1 cells: field rehash-method \ xt: ( wid -- )    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 wordlist-link \ link field to other wordlists    1 cells: field wordlist-link \ link field to other wordlists
 \   1 cells: field wordlist-extend \ points to wordlist extensions (eg hash)    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) ;  : 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,  Create f83search       ' f83find 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 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 lookup       G forth-wordlist lookup 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 wordlist-map @ find-method @ 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 ;
   
 Variable warnings  G -1 warnings T !  Variable warnings  G -1 warnings T !
   
Line 644  Variable warnings  G -1 warnings T ! Line 1051  Variable warnings  G -1 warnings T !
  then   then
  2drop 2drop ;   2drop 2drop ;
   
 : find   ( addr -- cfa +-1 / string false )  dup  : sfind ( c-addr u -- xt n / 0 )
   count search @ search-wordlist  dup IF  rot drop  THEN ;      lookup @ search-wordlist ;
   
   : find   ( addr -- cfa +-1 / string false )
       \ !! not ANS conformant: returns +-2 for restricted words
       dup count sfind dup if
           rot drop
       then ;
   
 : reveal ( -- )  : reveal ( -- )
  last? if   last? if
    name>string current @ check-shadow     name>string current @ check-shadow
  then   then
  current @ cell+ @ cell+ @ execute ;   current @ wordlist-map @ reveal-method @ execute ;
   
 : rehash  ( wid -- )  dup cell+ @ cell+ cell+ @ execute ;  : rehash  ( wid -- )  dup wordlist-map @ rehash-method @ execute ;
   
 : '    ( "name" -- addr )  name find 0= no.extensions ;  : '    ( "name" -- addr )  name sfind 0= if -&13 bounce then ;
 : [']  ( "name" -- addr )  ' postpone ALiteral ; immediate  : [']  ( "name" -- addr )  ' postpone ALiteral ; immediate
 \ Input                                                13feb93py  \ Input                                                13feb93py
   
 07 constant #bell  07 constant #bell
 08 constant #bs  08 constant #bs
   09 constant #tab
 7F constant #del  7F constant #del
 0D constant #cr                \ the newline key code  0D constant #cr                \ the newline key code
   0C constant #ff
 0A constant #lf  0A constant #lf
   
 : 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 683  Variable warnings  G -1 warnings T ! Line 1098  Variable warnings  G -1 warnings T !
 : (ret)  type-rest drop true space ;  : (ret)  type-rest drop true space ;
 : 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 ;
   : eof  2 pick 0=  IF  bye  ELSE  (ret)  THEN ;
   
 Create crtlkeys  Create ctrlkeys
   ] false false back  false  false false forw  false    ] false false back  false  eof   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 708  Create crtlkeys Line 1128  Create crtlkeys
   
 \ Output                                               13feb93py  \ Output                                               13feb93py
   
 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  Defer key
   ' (key) IS key
   
 \ : 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 728  DEFER type      \ defer type for a outpu Line 1151  DEFER type      \ defer type for a outpu
 \ Query                                                07apr93py  \ Query                                                07apr93py
   
 : refill ( -- flag )  : refill ( -- flag )
     blk @  IF  1 blk +!  true  0 >in !  EXIT  THEN
   tib /line    tib /line
   loadfile @ ?dup    loadfile @ ?dup
   IF    dup file-position throw linestart 2!    IF    read-line throw
         read-line throw    ELSE  loadline @ 0< IF 2drop false EXIT THEN
   ELSE  linestart @ 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  ( -- )  loadfile off  blk off  refill drop ;
   
 \ File specifiers                                       11jun93jaw  \ File specifiers                                       11jun93jaw
   
Line 755  DEFER type      \ defer type for a outpu Line 1178  DEFER type      \ defer type for a outpu
 \ : bin           dup 1 chars - c@  \ : bin           dup 1 chars - c@
 \                 r/o 4 chars + over - dup >r swap move r> ;  \                 r/o 4 chars + over - dup >r swap move r> ;
   
 : bin  1+ ;  : bin  1 or ;
   
 create nl$ 1 c, A c, 0 c, \ gnu includes usually a cr in dos  create nl$ 1 c, A c, 0 c, \ gnu includes usually a cr in dos
                            \ or not unix environments if                             \ or not unix environments if
Line 766  create nl$ 1 c, A c, 0 c, \ gnu includes Line 1189  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    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   ( throw-code -- throw-code )
   0 loadline ! blk off    dup IF
   BEGIN  refill  WHILE  interpret  REPEAT           source >in @ loadline @ loadfilename 2@
   loadfile @ close-file throw           error-stack dup @ dup 1+
            max-errors 1- min error-stack !
            6 * cells + cell+
            5 cells bounds swap DO
                               I !
            -1 cells +LOOP
     THEN
     r>
     r> >in !  r> #tib !  r> >tib !  r> blk !
     r> loadfile ! r> loadline !  >r ;
   
   r> >in !  r> #tib !  r> >tib ! r> blk !  : read-loop ( i*x -- j*x )
   r> loadfile ! r> loadline ! r> linestart ! ;    BEGIN  refill  WHILE  interpret  REPEAT ;
   
   : include-file ( i*x fid -- j*x )
     push-file  loadfile !
     0 loadline ! blk off  ['] read-loop catch
     loadfile @ close-file swap 2dup or
     pop-file  drop throw throw ;
   
   create pathfilenamebuf 256 chars allot \ !! make this grow on demand
   
   \ : check-file-prefix  ( addr len -- addr' len' flag )
   \   dup 0=                    IF  true EXIT  THEN 
   \   over c@ '/ =              IF  true EXIT  THEN 
   \   over 2 S" ./" compare 0=  IF  true EXIT  THEN 
   \   over 3 S" ../" compare 0= IF  true EXIT  THEN
   \   over 2 S" ~/" compare 0=
   \   IF     1 /string
   \          S" HOME" getenv tuck pathfilenamebuf swap move
   \          2dup + >r pathfilenamebuf + swap move
   \          pathfilenamebuf r> true
   \   ELSE   false
   \   THEN ;
   
   : open-path-file ( c-addr1 u1 -- file-id c-addr2 u2 )
       \ opens a file for reading, searching in the path for it (unless
       \ the filename contains a slash); c-addr2 u2 is the full filename
       \ (valid until the next call); if the file is not found (or in
       \ case of other errors for each try), -38 (non-existant file) is
       \ thrown. Opening for other access modes makes little sense, as
       \ the path will usually contain dirs that are only readable for
       \ the user
       \ !! use file-status to determine access mode?
       2dup [char] / scan nip ( 0<> )
       if \ the filename contains a slash
           2dup r/o open-file throw ( c-addr1 u1 file-id )
           -rot >r pathfilenamebuf r@ cmove ( file-id R: u1 )
           pathfilenamebuf r> EXIT
       then
       pathdirs 2@ 0
   \    check-file-prefix 0= 
   \    IF  pathdirs 2@ 0
       ?DO ( c-addr1 u1 dirnamep )
           dup >r 2@ dup >r pathfilenamebuf swap cmove ( addr u )
           2dup pathfilenamebuf r@ chars + swap cmove ( addr u )
           pathfilenamebuf over r> + dup >r r/o open-file 0=
           IF ( addr u file-id )
               nip nip r> rdrop 0 LEAVE
           THEN
           rdrop drop r> cell+ cell+
       LOOP
   \    ELSE   2dup open-file throw -rot  THEN 
       0<> -&38 and throw ( file-id u2 )
       pathfilenamebuf swap ;
   
   create included-files 0 , 0 , ( pointer to and count of included files )
   
   : included? ( c-addr u -- f )
       \ true, iff filename c-addr u is in included-files
       included-files 2@ 0
       ?do ( c-addr u addr )
           dup >r 2@ 2over compare 0=
           if
               2drop rdrop unloop
               true EXIT
           then
           r> cell+ cell+
       loop
       2drop drop false ;
   
   : add-included-file ( c-addr u -- )
       \ add name c-addr u to included-files
       included-files 2@ tuck 1+ 2* cells resize throw
       swap 2dup 1+ included-files 2!
       2* cells + 2! ;
   
   : save-string           ( addr1 u -- addr2 u )
       swap >r
       dup allocate throw
       swap 2dup r> -rot move ;
   
   : included1 ( i*x file-id c-addr u -- j*x )
       \ include the file file-id with the name given by c-addr u
       loadfilename 2@ >r >r
       save-string 2dup loadfilename 2! add-included-file ( file-id )
       ['] include-file catch
       r> r> loadfilename 2!  throw ;
       
 : included ( i*x addr u -- j*x )  : included ( i*x addr u -- j*x )
   r/o open-file throw include-file ;      open-path-file included1 ;
   
   : required ( i*x addr u -- j*x )
       \ include the file with the name given by addr u, if it is not
       \ included already. Currently this works by comparing the name of
       \ the file (with path) against the names of earlier included
       \ files; however, it would probably be better to fstat the file,
       \ and compare the device and inode. The advantages would be: no
       \ problems with several paths to the same file (e.g., due to
       \ links) and we would catch files included with include-file and
       \ write a require-file.
       open-path-file 2dup included?
       if
           2drop close-file throw
       else
           included1
       then ;
   
 \ HEX DECIMAL                                           2may93jaw  \ HEX DECIMAL                                           2may93jaw
   
Line 789  create nl$ 1 c, A c, 0 c, \ gnu includes Line 1322  create nl$ 1 c, A c, 0 c, \ gnu includes
 \ DEPTH                                                 9may93jaw  \ DEPTH                                                 9may93jaw
   
 : depth ( -- +n )  sp@ s0 @ swap - cell / ;  : depth ( -- +n )  sp@ s0 @ swap - cell / ;
   : clearstack ( ... -- )  s0 @ sp! ;
   
 \ INCLUDE                                               9may93jaw  \ INCLUDE                                               9may93jaw
   
 : include  ( "file" -- )  : include  ( "file" -- )
   bl word count included ;    name included ;
   
   : require  ( "file" -- )
     name required ;
   
 \ 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 last off ; 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 809  create nl$ 1 c, A c, 0 c, \ gnu includes Line 1349  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  \  BEGIN  interpret  >in @ #tib @ u>= UNTIL
   >in off blk off loadfile off -1 linestart !    ['] interpret catch
     pop-file throw ;
   BEGIN  interpret  >in @ #tib @ u>= UNTIL  
   
   r> >in !  r> #tib !  r> >tib ! r> blk !  
   r> loadfile ! r> loadline ! r> linestart ! ;  
   
   
 : abort -1 throw ;  : abort -1 throw ;
Line 836  Defer .status Line 1372  Defer .status
   
 \ DOERROR (DOERROR)                                     13jun93jaw  \ DOERROR (DOERROR)                                     13jun93jaw
   
   8 Constant max-errors
   Variable error-stack  0 error-stack !
   max-errors 6 * cells allot
   \ format of one cell:
   \ source ( addr u )
   \ >in
   \ line-number
   \ Loadfilename ( addr u )
   
   : 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
       bounds ?do
           i c@ 9 = if \ check for tab
               9
           else
               bl
           then
           emit
       loop
   ;
   
 DEFER DOERROR  DEFER DOERROR
   
   : .error-frame ( addr1 u1 n1 n2 addr2 u2 -- )
     cr error-stack @
     IF
        ." in file included from "
        type ." :" dec.  drop 2drop
     ELSE
        type ." :" dec.
        cr dup 2over type cr drop
        nip -trailing 1- ( line-start index2 )
        0 >r  BEGIN
                     2dup + c@ bl >  WHILE
                     r> 1+ >r  1- dup 0<  UNTIL  THEN  1+
        ( line-start index1 )
        typewhite
        r> 1 max 0 ?do \ we want at least one "^", even if the length is 0
                     [char] ^ emit
        loop
     THEN
   ;
   
 : (DoError) ( throw-code -- )  : (DoError) ( throw-code -- )
          LoadFile @    loadline @ IF
          IF                 source >in @ loadline @ 0 0 .error-frame
                 ." Error in line: " Loadline @ . cr    THEN
          THEN    error-stack @ 0 ?DO
          cr source type cr      -1 error-stack +!
          source drop >in @ -trailing      error-stack dup @ 6 * cells + cell+
          here c@ 1F min dup >r - 1- 0 max nip      6 cells bounds DO
          dup spaces         I @
          IF      cell +LOOP
                 ." ^"      .error-frame
          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 883  DEFER DOERROR Line 1460  DEFER DOERROR
 \ : words  listwords @  \ : words  listwords @
 \          BEGIN  @ dup  WHILE  dup .name  REPEAT drop ;  \          BEGIN  @ dup  WHILE  dup .name  REPEAT drop ;
   
 : >len  ( cstring -- addr n )  100 0 scan 0 swap 100 - /string ;  : cstring>sstring  ( cstring -- addr n )  -1 0 scan 0 swap 1+ /string ;
 : arg ( n -- addr count )  cells argv @ + @ >len ;  : arg ( n -- addr count )  cells argv @ + @ cstring>sstring ;
 : #!       postpone \ ;  immediate  : #!       postpone \ ;  immediate
   
 Variable env  Create pathstring 2 cells allot \ string
   Create pathdirs   2 cells allot \ dir string array, pointer and count
 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  : process-path ( addr1 u1 -- addr2 u2 )
   >in off #tib @ 0<> #tib +! ;      \ addr1 u1 is a path string, addr2 u2 is an array of dir strings
       here >r
 : script? ( -- flag )  0 arg 1 arg dup 3 pick - /string compare 0= ;      BEGIN
           over >r [char] : scan
 : cold ( -- )            over r> tuck - ( rest-str this-str )
   argc @ 1 >          dup
   IF  script?          IF
       IF  1 arg ['] included  ELSE   get-args ['] interpret  THEN              2dup 1- chars + c@ [char] / <>
       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 ;                  2dup chars + [char] / swap c!
                   1+
 : boot ( **env **argv argc -- )              THEN
   argc ! argv ! env !  main-task up!              2,
   sp@ dup s0 ! $10 + >tib ! rp@ r0 !  fp@ f0 !  cold ;          ELSE
               2drop
           THEN
           dup
       WHILE
           1 /string
       REPEAT
       2drop
       here r> tuck - 2 cells / ;
   
   : do-option ( addr1 len1 addr2 len2 -- n )
       2swap
       2dup s" -e"         compare  0= >r
       2dup s" --evaluate" compare  0= r> or
       IF  2drop dup >r ['] evaluate catch
           ?dup IF  dup >r DoError r> negate (bye)  THEN
           r> >tib +!  2 EXIT  THEN
       ." Unknown option: " type cr 2drop 1 ;
   
   : process-args ( -- )
       >tib @ >r
       argc @ 1
       ?DO
           I arg over c@ [char] - <>
           IF
               required 1
           ELSE
               I 1+ argc @ =  IF  s" "  ELSE  I 1+ arg  THEN
               do-option
           THEN
       +LOOP
       r> >tib ! ;
   
   Defer 'cold ' noop IS 'cold
   
   : cold ( -- )
       pathstring 2@ process-path pathdirs 2!
       0 0 included-files 2!
       'cold
       argc @ 1 >
       IF
           true to script?
           ['] process-args catch ?dup
           IF
               dup >r DoError cr r> negate (bye)
           THEN
           cr
       THEN
       false to script?
       ." GNU Forth " version-string type ." , Copyright (C) 1994 Free Software Foundation, Inc." cr
       ." GNU Forth comes with ABSOLUTELY NO WARRANTY; for details type `license'" cr
       ." Type `bye' to exit"
       loadline off 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 ( path **argv argc -- )
     argc ! argv ! cstring>sstring pathstring 2!  main-task up!
     sp@ dup s0 ! $10 + >tib ! #tib off >in off
     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.7  
changed lines
  Added in v.1.40


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