Diff for /gforth/Attic/kernel.fs between versions 1.2 and 1.17

version 1.2, 1996/09/23 08:52:49 version 1.17, 1997/03/04 22:09:54
Line 20 Line 20
   
 \ Idea and implementation: Bernd Paysan (py)  \ Idea and implementation: Bernd Paysan (py)
   
 \ Log:  ', '- usw. durch [char] ... ersetzt  
 \       man sollte die unterschiedlichen zahlensysteme  
 \       mit $ und & zumindest im interpreter weglassen  
 \       schon erledigt!  
 \       11may93jaw  
 \ name>         0= nicht vorhanden              17may93jaw  
 \               nfa can be lfa or nfa!  
 \ find          splited into find and (find)  
 \               (find) for later use            17may93jaw  
 \ search        replaced by lookup because  
 \               it is a word of the string wordset  
 \                                               20may93jaw  
 \ postpone      added immediate                 21may93jaw  
 \ to            added immediate                 07jun93jaw  
 \ cfa, header   put "here lastcfa !" in  
 \               cfa, this is more logical  
 \               and noname: works wothout  
 \               extra "here lastcfa !"          08jun93jaw  
 \ (parse-white) thrown out  
 \ refill        added outer trick  
 \               to show there is something  
 \               going on                        09jun93jaw  
 \ leave ?leave  somebody forgot UNLOOP!!!       09jun93jaw  
 \ leave ?leave  unloop thrown out  
 \               unloop after loop is used       10jun93jaw  
   
 HEX  HEX
   
 \ labels for some code addresses  \ labels for some code addresses
   
   doer? :docon [IF]
 : docon: ( -- addr )    \ gforth  : docon: ( -- addr )    \ gforth
     \ the code address of a @code{CONSTANT}      \G the code address of a @code{CONSTANT}
     ['] bl >code-address ;      ['] bl >code-address ;
   [THEN]
   
 : docol: ( -- addr )    \ gforth  : docol: ( -- addr )    \ gforth
     \ the code address of a colon definition      \G the code address of a colon definition
     ['] docon: >code-address ;      ['] docol: >code-address ;
   
   doer? :dovar [IF]
 : dovar: ( -- addr )    \ gforth  : dovar: ( -- addr )    \ gforth
     \ the code address of a @code{CREATE}d word      \G the code address of a @code{CREATE}d word
     ['] udp >code-address ;      ['] udp >code-address ;
   [THEN]
   
   doer? :douser [IF]
 : douser: ( -- addr )   \ gforth  : douser: ( -- addr )   \ gforth
     \ the code address of a @code{USER} variable      \G the code address of a @code{USER} variable
     ['] s0 >code-address ;      ['] s0 >code-address ;
   [THEN]
   
   doer? :dodefer [IF]
 : dodefer: ( -- addr )  \ gforth  : dodefer: ( -- addr )  \ gforth
     \ the code address of a @code{defer}ed word      \G the code address of a @code{defer}ed word
     ['] source >code-address ;      ['] source >code-address ;
   [THEN]
   
   doer? :dofield [IF]
 : dofield: ( -- addr )  \ gforth  : dofield: ( -- addr )  \ gforth
     \ the code address of a @code{field}      \G the code address of a @code{field}
     ['] reveal-method >code-address ;      ['] reveal-method >code-address ;
   [THEN]
   
   has-prims 0= [IF]
   : dodoes: ( -- addr )   \ gforth
       \G the code address of a @code{field}
       ['] spaces >code-address ;
   [THEN]
   
 NIL AConstant NIL \ gforth  NIL AConstant NIL \ gforth
   
   \ Aliases
   
   ' i Alias r@
   
 \ Bit string manipulation                              06oct92py  \ Bit string manipulation                              06oct92py
   
 \ Create bits  80 c, 40 c, 20 c, 10 c, 8 c, 4 c, 2 c, 1 c,  \ Create bits  80 c, 40 c, 20 c, 10 c, 8 c, 4 c, 2 c, 1 c,
Line 118  NIL AConstant NIL \ gforth Line 112  NIL AConstant NIL \ gforth
     LOOP ;      LOOP ;
   
 \ !! this is machine-dependent, but works on all but the strangest machines  \ !! this is machine-dependent, but works on all but the strangest machines
 ' faligned Alias maxaligned ( addr1 -- addr2 ) \ gforth  
 ' falign Alias maxalign ( -- ) \ gforth  : maxaligned ( addr -- f-addr ) \ float
       [ /maxalign 1 - ] Literal + [ 0 /maxalign - ] Literal and ;
   : maxalign ( -- ) \ float
       here dup maxaligned swap
       ?DO
           bl c,
       LOOP ;
   
 \ !! machine-dependent and won't work if "0 >body" <> "0 >body maxaligned"  \ !! machine-dependent and won't work if "0 >body" <> "0 >body maxaligned"
 ' maxaligned Alias cfaligned ( addr1 -- addr2 ) \ gforth  ' maxaligned Alias cfaligned ( addr1 -- addr2 ) \ gforth
Line 178  $20 constant restrict-mask Line 178  $20 constant restrict-mask
 : bounds ( beg count -- end beg ) \ gforth  : bounds ( beg count -- end beg ) \ gforth
     over + swap ;      over + swap ;
   
 : save-mem      ( addr1 u -- addr2 u ) \ gforth  
     \ copy a memory block into a newly allocated region in the heap  
     swap >r  
     dup allocate throw  
     swap 2dup r> -rot move ;  
   
 : extend-mem    ( addr1 u1 u -- addr addr2 u2 )  
     \ extend memory block allocated from the heap by u aus  
     \ the (possibly reallocated piece is addr2 u2, the extension is at addr  
     over >r + dup >r resize throw  
     r> over r> + -rot ;  
   
 \ input stream primitives                              23feb93py  \ input stream primitives                              23feb93py
   
 : tib ( -- c-addr ) \ core-ext  : tib ( -- c-addr ) \ core-ext
Line 276  Defer source ( -- addr count ) \ core Line 264  Defer source ( -- addr count ) \ core
 : (compile) ( -- ) \ gforth  : (compile) ( -- ) \ gforth
     r> dup cell+ >r @ compile, ;      r> dup cell+ >r @ compile, ;
   
 \ not the most efficient implementation of POSTPONE, but simple  : postpone, ( w xt -- )
 : POSTPONE ( -- ) \ core      \g Compiles the compilation semantics represented by @var{w xt}.
     COMP' swap POSTPONE aliteral compile, ; immediate restrict      dup ['] execute =
       if
           drop compile,
       else
           dup ['] compile, =
           if
               drop POSTPONE (compile) compile,
           else
               swap POSTPONE aliteral compile,
           then
       then ;
   
   : POSTPONE ( "name" -- ) \ core
       \g Compiles the compilation semantics of @var{name}.
       COMP' postpone, ; immediate restrict
   
 : interpret/compile: ( interp-xt comp-xt "name" -- ) \ gforth  : interpret/compile: ( interp-xt comp-xt "name" -- ) \ gforth
     Create immediate swap A, A,      Create immediate swap A, A,
Line 325  DOES> Line 327  DOES>
 \ number? number                                       23feb93py  \ number? number                                       23feb93py
   
 Create bases   10 ,   2 ,   A , 100 ,  Create bases   10 ,   2 ,   A , 100 ,
 \              16     2    10   Zeichen  \              16     2    10   character
 \ !! this saving and restoring base is an abomination! - anton  \ !! this saving and restoring base is an abomination! - anton
 : getbase ( addr u -- addr' u' )  : getbase ( addr u -- addr' u' )
     over c@ [char] $ - dup 4 u<      over c@ [char] $ - dup 4 u<
Line 427  hex Line 429  hex
   
 : #s      ( +d -- 0 0 ) \ core  number-sign-s  : #s      ( +d -- 0 0 ) \ core  number-sign-s
     BEGIN      BEGIN
         # 2dup d0=          # 2dup or 0=
     UNTIL ;      UNTIL ;
   
 \ print numbers                                        07jun92py  \ print numbers                                        07jun92py
Line 460  hex Line 462  hex
 \ !! 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
   
   has-locals [IF]
 : lp@ ( -- addr ) \ gforth      l-p-fetch  : lp@ ( -- addr ) \ gforth      l-p-fetch
  laddr# [ 0 , ] ;   laddr# [ 0 , ] ;
   [THEN]
   
   Defer 'catch
   Defer 'throw
   
   ' noop IS 'catch
   ' noop IS 'throw
   
 : catch ( x1 .. xn xt -- y1 .. ym 0 / z1 .. zn error ) \ exception  : catch ( x1 .. xn xt -- y1 .. ym 0 / z1 .. zn error ) \ exception
   >r sp@ r> swap >r       \ don't count xt! jaw      'catch
   fp@ >r      sp@ >r
   lp@ >r  [ has-floats [IF] ]
   handler @ >r      fp@ >r
   rp@ handler !  [ [THEN] ]
   execute  [ has-locals [IF] ]
   r> handler ! rdrop rdrop rdrop 0 ;      lp@ >r
   [ [THEN] ]
       handler @ >r
       rp@ handler !
       execute
       r> handler ! rdrop rdrop rdrop 0 ;
   
 : throw ( y1 .. ym error/0 -- y1 .. ym / z1 .. zn error ) \ exception  : throw ( y1 .. ym error/0 -- y1 .. ym / z1 .. zn error ) \ exception
     ?DUP IF      ?DUP IF
         [ here 9 cells ! ]          [ has-header [IF] here 9 cells ! [THEN] ] \ entry point for signal handler
         handler @ rp!          handler @ dup 0= IF
   [ has-os [IF] ]
               2 (bye)
   [ [ELSE] ]
               quit
   [ [THEN] ]
           THEN
           rp!
         r> handler !          r> handler !
         r> lp!  [ has-locals [IF] ]
           r> lp!
   [ [THEN] ]
   [ has-floats [IF] ]
         r> fp!          r> fp!
         r> swap >r sp! r>  [ [THEN] ]
           r> swap >r sp! drop r>
           'throw
     THEN ;      THEN ;
   
 \ Bouncing is very fine,  \ Bouncing is very fine,
Line 487  hex Line 514  hex
 : bounce ( y1 .. ym error/0 -- y1 .. ym error / y1 .. ym ) \ gforth  : bounce ( y1 .. ym error/0 -- y1 .. ym error / y1 .. ym ) \ gforth
 \ a throw without data or fp stack restauration  \ a throw without data or fp stack restauration
   ?DUP IF    ?DUP IF
     handler @ rp!        handler @ rp!
     r> handler !        r> handler !
     r> lp!  [ has-locals [IF] ]
     rdrop        r> lp!
     rdrop  [ [THEN] ]
   [ has-floats [IF] ]
         rdrop
   [ [THEN] ]
         rdrop
         'throw
   THEN ;    THEN ;
   
 \ ?stack                                               23feb93py  \ ?stack                                               23feb93py
   
 : ?stack ( ?? -- ?? ) \ gforth  : ?stack ( ?? -- ?? ) \ gforth
     sp@ s0 @ > IF    -4 throw  THEN      sp@ s0 @ u> IF    -4 throw  THEN
     fp@ f0 @ > IF  -&45 throw  THEN  ;  [ has-floats [IF] ]
       fp@ f0 @ u> IF  -&45 throw  THEN
   [ [THEN] ]
   ;
 \ ?stack should be code -- it touches an empty stack!  \ ?stack should be code -- it touches an empty stack!
   
 \ interpret                                            10mar92py  \ interpret                                            10mar92py
Line 546  Defer interpreter-notfound ( c-addr coun Line 581  Defer interpreter-notfound ( c-addr coun
   
 : compiler ( c-addr u -- )  : compiler ( c-addr u -- )
     2dup find-name dup      2dup find-name dup
     if ( c-addr u nfa )      if ( c-addr u nt )
         nip nip name>comp execute          nip nip name>comp execute
     else      else
         drop          drop
Line 570  Defer interpreter-notfound ( c-addr coun Line 605  Defer interpreter-notfound ( c-addr coun
 : ] ( -- ) \ core       right-bracket  : ] ( -- ) \ core       right-bracket
     ['] compiler     IS parser state on  ;      ['] compiler     IS parser state on  ;
   
 \ locals stuff needed for control structures  
   
 : compile-lp+! ( n -- ) \ gforth        compile-l-p-plus-store  
     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 -- ) \ gforth  
     \ 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 ( -- ) \ gforth  
     \ declares the current point of execution as unreachable  
     dead-code on  
     0 backedge-locals ! ; immediate  
   
 : ASSUME-LIVE ( orig -- orig ) \ gforth  
     \ used immediatly 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 ) \ gforth-internal  
 \ 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 ) \ gforth-internal  
 \ true iff list1 is a sublist of list2  
  begin  
    2dup u<  
  while  
    @  
  repeat  
  = ;  
   
 : list-size ( list -- u ) \ gforth-internal  
 \ 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 ) \ tools-ext  
  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 ) \ tools-ext  
  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  
   
 : ?struc      ( flag -- )       abort" unstructured " ;  
 : sys?        ( sys -- )        dup 0= ?struc ;  
 : >mark ( -- orig )  
  cs-push-orig 0 , ;  
 : >resolve    ( addr -- )        here over - swap ! ;  
 : <resolve    ( addr -- )        here - , ;  
   
 : BUT  
     1 cs-roll ;                      immediate restrict  
 : YET  
     0 cs-pick ;                       immediate restrict  
   
 \ Structural Conditionals                              12dec92py  
   
 : AHEAD ( compilation -- orig ; run-time -- ) \ tools-ext  
     POSTPONE branch  >mark  POSTPONE unreachable ; immediate restrict  
   
 : IF ( compilation -- orig ; run-time f -- ) \ core  
  POSTPONE ?branch >mark ; immediate restrict  
   
 : ?DUP-IF ( compilation -- orig ; run-time n -- n| ) \ gforth   question-dupe-if  
 \ This is the preferred alternative to the idiom "?DUP IF", since it can be  
 \ better handled by tools like stack checkers. Besides, it's faster.  
     POSTPONE ?dup-?branch >mark ;       immediate restrict  
   
 : ?DUP-0=-IF ( compilation -- orig ; run-time n -- n| ) \ gforth        question-dupe-zero-equals-if  
     POSTPONE ?dup-0=-?branch >mark ;       immediate restrict  
   
 : then-like ( orig -- addr )  
     swap -rot dead-orig =  
     if  
         drop  
     else  
         dead-code @  
         if  
             set-locals-size-list dead-code off  
         else \ both live  
             dup list-size adjust-locals-size  
             locals-list @ common-list dup list-size adjust-locals-size  
             locals-list !  
         then  
     then ;  
   
 : THEN ( compilation orig -- ; run-time -- ) \ core  
     dup orig?  then-like  >resolve ; immediate restrict  
   
 ' THEN alias ENDIF ( compilation orig -- ; run-time -- ) \ gforth  
 immediate restrict  
 \ 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  
 \ brought up with fig-Forth).  
   
 : ELSE ( compilation orig1 -- orig2 ; run-time f -- ) \ core  
     POSTPONE ahead  
     1 cs-roll  
     POSTPONE then ; immediate restrict  
   
   
 : BEGIN ( compilation -- dest ; run-time -- ) \ core  
     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-like ( dest -- addr )  
     over list-size adjust-locals-size  
     swap check-begin  POSTPONE unreachable ;  
   
 : AGAIN ( compilation dest -- ; run-time -- ) \ core-ext  
     dest? again-like  POSTPONE branch  <resolve ; 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 ( compilation dest -- ; run-time f -- ) \ core  
     dest? ['] ?branch ['] ?branch-lp+!# until-like ; immediate restrict  
   
 : WHILE ( compilation dest -- orig dest ; run-time f -- ) \ core  
     POSTPONE if  
     1 cs-roll ; immediate restrict  
   
 : REPEAT ( compilation orig dest -- ; run-time -- ) \ core  
     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 ( compilation orig -- ; run-time -- ) \ gforth  
     \ !! the original done had ( addr -- )  
     drop >r drop  
     begin  
         leave>  
         over r@ u>=  
     while  
         POSTPONE then  
     repeat  
     >leave rdrop ; immediate restrict  
   
 : LEAVE ( compilation -- ; run-time loop-sys -- ) \ core  
     POSTPONE ahead  
     >leave ; immediate restrict  
   
 : ?LEAVE ( compilation -- ; run-time f | f loop-sys -- ) \ gforth       question-leave  
     POSTPONE 0= POSTPONE if  
     >leave ; immediate restrict  
   
 : DO ( compilation -- do-sys ; run-time w1 w2 -- loop-sys ) \ core  
     POSTPONE (do)  
     POSTPONE begin drop do-dest  
     ( 0 0 0 >leave ) ; immediate restrict  
   
 : ?do-like ( -- do-sys )  
     ( 0 0 0 >leave )  
     >mark >leave  
     POSTPONE begin drop do-dest ;  
   
 : ?DO ( compilation -- do-sys ; run-time w1 w2 -- | loop-sys )  \ core-ext      question-do  
     POSTPONE (?do) ?do-like ; immediate restrict  
   
 : +DO ( compilation -- do-sys ; run-time n1 n2 -- | loop-sys )  \ gforth        plus-do  
     POSTPONE (+do) ?do-like ; immediate restrict  
   
 : U+DO ( compilation -- do-sys ; run-time u1 u2 -- | loop-sys ) \ gforth        u-plus-do  
     POSTPONE (u+do) ?do-like ; immediate restrict  
   
 : -DO ( compilation -- do-sys ; run-time n1 n2 -- | loop-sys )  \ gforth        minus-do  
     POSTPONE (-do) ?do-like ; immediate restrict  
   
 : U-DO ( compilation -- do-sys ; run-time u1 u2 -- | loop-sys ) \ gforth        u-minus-do  
     POSTPONE (u-do) ?do-like ; immediate restrict  
   
 : FOR ( compilation -- do-sys ; run-time u -- loop-sys )        \ gforth  
     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 ( compilation do-sys -- ; run-time loop-sys1 -- | loop-sys2 )    \ core  
  ['] (loop) ['] (loop)-lp+!# loop-like ; immediate restrict  
   
 : +LOOP ( compilation do-sys -- ; run-time loop-sys1 n -- | loop-sys2 ) \ core  plus-loop  
  ['] (+loop) ['] (+loop)-lp+!# loop-like ; immediate restrict  
   
 \ !! should the compiler warn about +DO..-LOOP?  
 : -LOOP ( compilation do-sys -- ; run-time loop-sys1 u -- | loop-sys2 ) \ gforth        minus-loop  
  ['] (-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 ( compilation do-sys -- ; run-time loop-sys1 n -- | loop-sys2 )        \ gforth        s-plus-loop  
  ['] (s+loop) ['] (s+loop)-lp+!# loop-like ; immediate restrict  
   
 : NEXT ( compilation do-sys -- ; run-time loop-sys1 -- | loop-sys2 ) \ gforth  
  ['] (next) ['] (next)-lp+!# loop-like ; immediate restrict  
   
 \ Structural Conditionals                              12dec92py  
   
 : EXIT ( compilation -- ; run-time nest-sys -- ) \ core  
     0 adjust-locals-size  
     POSTPONE ;s  
     POSTPONE unreachable ; immediate restrict  
   
 : ?EXIT ( -- ) ( compilation -- ; run-time nest-sys f -- | nest-sys ) \ gforth  
      POSTPONE if POSTPONE exit POSTPONE then ; immediate restrict  
   
 \ Strings                                              22feb93py  \ Strings                                              22feb93py
   
 : ," ( "string"<"> -- ) [char] " parse  : ," ( "string"<"> -- ) [char] " parse
Line 967  Avariable leave-sp  leave-stack 3 cells Line 617  Avariable leave-sp  leave-stack 3 cells
     postpone (S") here over char+ allot  place align ;      postpone (S") here over char+ allot  place align ;
                                              immediate restrict                                               immediate restrict
 : ( ( compilation 'ccc<close-paren>' -- ; run-time -- ) \ core,file     paren  : ( ( compilation 'ccc<close-paren>' -- ; run-time -- ) \ core,file     paren
     BEGIN      [char] ) parse 2drop ; immediate
         >in @ [char] ) parse nip >in @ rot - =  
     WHILE  
         loadfile @ IF  
             refill 0= abort" missing ')' in paren comment"  
         THEN  
     REPEAT ;                       immediate  
 : \ ( -- ) \ core-ext backslash  : \ ( -- ) \ core-ext backslash
     blk @      blk @
     IF      IF
Line 1028  defer header ( -- ) \ gforth Line 673  defer header ( -- ) \ gforth
 ' (header) IS header  ' (header) IS header
   
 : string, ( c-addr u -- ) \ gforth  : string, ( c-addr u -- ) \ gforth
     \ puts down string as cstring      \G puts down string as cstring
     dup c, here swap chars dup allot move ;      dup c, here swap chars dup allot move ;
   
 : header, ( c-addr u -- ) \ gforth  : header, ( c-addr u -- ) \ gforth
Line 1042  defer header ( -- ) \ gforth Line 687  defer header ( -- ) \ gforth
 : input-stream-header ( "name" -- )  : input-stream-header ( "name" -- )
     name name-too-short? header, ;      name name-too-short? header, ;
 : input-stream ( -- )  \ general  : input-stream ( -- )  \ general
 \ switches back to getting the name from the input stream ;      \G 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)
Line 1078  create nextname-buffer 32 chars allot Line 723  create nextname-buffer 32 chars allot
     alias-mask lastflags creset      alias-mask lastflags creset
     dup A, lastcfa ! ;      dup A, lastcfa ! ;
   
 : name>string ( nfa -- addr count ) \ gforth    name-to-string  : name>string ( nt -- addr count ) \ gforth     name-to-string
  cell+ count $1F and ;      \g @var{addr count} is the name of the word represented by @var{nt}.
       cell+ count $1F and ;
   
 Create ???  0 , 3 c, char ? c, char ? c, char ? c,  Create ???  0 , 3 c, char ? c, char ? c, char ? c,
 : >name ( cfa -- nfa ) \ gforth to-name  : >name ( cfa -- nt ) \ gforth  to-name
  $21 cell do   $21 cell do
    dup i - count $9F and + cfaligned over alias-mask + = if     dup i - count $9F and + cfaligned over alias-mask + = if
      i - cell - unloop exit       i - cell - unloop exit
Line 1101  Create ???  0 , 3 c, char ? c, char ? c, Line 747  Create ???  0 , 3 c, char ? c, char ? c,
 : !does    ( addr -- ) \ gforth store-does  : !does    ( addr -- ) \ gforth store-does
     lastxt does-code! ;      lastxt does-code! ;
 : (does>)  ( R: addr -- )  : (does>)  ( R: addr -- )
     r> /does-handler + !does ;      r> cfaligned /does-handler + !does ;
 : dodoes,  ( -- )  : dodoes,  ( -- )
   here /does-handler allot does-handler! ;    cfalign here /does-handler allot does-handler! ;
   
   doer? :dovar [IF]
 : Create ( "name" -- ) \ core  : Create ( "name" -- ) \ core
     Header reveal dovar: cfa, ;      Header reveal dovar: cfa, ;
   [ELSE]
   : Create ( "name" -- ) \ core
       Header reveal here lastcfa ! 0 A, 0 , DOES> ;
   [THEN]
   
 \ Create Variable User Constant                        17mar93py  \ Create Variable User Constant                        17mar93py
   
Line 1114  Create ???  0 , 3 c, char ? c, char ? c, Line 765  Create ???  0 , 3 c, char ? c, char ? c,
     Create 0 , ;      Create 0 , ;
 : AVariable ( "name" -- ) \ gforth  : AVariable ( "name" -- ) \ gforth
     Create 0 A, ;      Create 0 A, ;
 : 2VARIABLE ( "name" -- ) \ double  : 2Variable ( "name" -- ) \ double
     create 0 , 0 , ;      create 0 , 0 , ;
       
   : uallot ( n -- )  udp @ swap udp +! ;
   
   doer? :douser [IF]
 : User ( "name" -- ) \ gforth  : User ( "name" -- ) \ gforth
     Variable ;      Header reveal douser: cfa, cell uallot , ;
 : AUser ( "name" -- ) \ gforth  : AUser ( "name" -- ) \ gforth
     AVariable ;      User ;
   [ELSE]
 : (Constant)  Header reveal docon: cfa, ;  : User Create uallot , DOES> @ up @ + ;
   : AUser User ;
   [THEN]
   
   doer? :docon [IF]
       : (Constant)  Header reveal docon: cfa, ;
   [ELSE]
       : (Constant)  Create DOES> @ ;
   [THEN]
 : Constant ( w "name" -- ) \ core  : Constant ( w "name" -- ) \ core
     \ \G Defines constant @var{name}      \G Defines constant @var{name}
     \ \G      \G  
     \ \G @var{name} execution: @var{-- w}      \G @var{name} execution: @var{-- w}
     (Constant) , ;      (Constant) , ;
 : AConstant ( addr "name" -- ) \ gforth  : AConstant ( addr "name" -- ) \ gforth
     (Constant) A, ;      (Constant) A, ;
   : Value ( w "name" -- ) \ core-ext
       (Constant) , ;
   
 : 2Constant ( w1 w2 "name" -- ) \ double  : 2Constant ( w1 w2 "name" -- ) \ double
     Create ( w1 w2 "name" -- )      Create ( w1 w2 "name" -- )
Line 1137  Create ???  0 , 3 c, char ? c, char ? c, Line 801  Create ???  0 , 3 c, char ? c, char ? c,
     DOES> ( -- w1 w2 )      DOES> ( -- w1 w2 )
         2@ ;          2@ ;
           
   doer? :dofield [IF]
       : (Field)  Header reveal dofield: cfa, ;
   [ELSE]
       : (Field)  Create DOES> @ + ;
   [THEN]
 \ IS Defer What's Defers TO                            24feb93py  \ IS Defer What's Defers TO                            24feb93py
   
   doer? :dodefer [IF]
 : Defer ( "name" -- ) \ gforth  : Defer ( "name" -- ) \ gforth
     \ !! shouldn't it be initialized with abort or something similar?      \ !! shouldn't it be initialized with abort or something similar?
     Header Reveal dodefer: cfa,      Header Reveal dodefer: cfa,
     ['] noop A, ;      ['] noop A, ;
 \     Create ( -- )   [ELSE]
 \       ['] noop A,  : Defer ( "name" -- ) \ gforth
 \     DOES> ( ??? )      Create ['] noop A,
 \       perform ;  DOES> @ execute ;
   [THEN]
   
 : Defers ( "name" -- ) \ gforth  : Defers ( "name" -- ) \ gforth
     ' >body @ compile, ; immediate      ' >body @ compile, ; immediate
Line 1171  AVariable current ( -- addr ) \ gforth Line 842  AVariable current ( -- addr ) \ gforth
   
 : last?   ( -- false / nfa nfa )  : last?   ( -- false / nfa nfa )
     last @ ?dup ;      last @ ?dup ;
 : (reveal) ( nfa wid -- )  : (reveal) ( nt wid -- )
     ( wid>wordlist-id ) dup >r      ( wid>wordlist-id ) dup >r
     @ over ( name>link ) !       @ over ( name>link ) ! 
     r> ! ;      r> ! ;
Line 1181  AVariable current ( -- addr ) \ gforth Line 852  AVariable current ( -- addr ) \ gforth
 \ word list structure:  \ word list structure:
   
 struct  struct
   1 cells: field find-method   \ xt: ( c_addr u wid -- name-id )    1 cells: field find-method   \ xt: ( c_addr u wid -- nt )
   1 cells: field reveal-method \ xt: ( nfa wid -- ) \ used by dofield:, must be field    1 cells: field reveal-method \ xt: ( nt wid -- ) \ used by dofield:, must be field
   1 cells: field rehash-method \ xt: ( wid -- )    1 cells: field rehash-method \ xt: ( wid -- )
 \   \ !! what else  \   \ !! what else
 end-struct wordlist-map-struct  end-struct wordlist-map-struct
Line 1194  struct Line 865  struct
   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      ( addr len wordlist -- nt / false )
     ( wid>wordlist-id ) @ (f83find) ;      ( wid>wordlist-id ) @ (f83find) ;
   
 \ Search list table: find reveal  \ Search list table: find reveal
Line 1231  end-struct interpret/compile-struct Line 902  end-struct interpret/compile-struct
         (cfa>int)          (cfa>int)
     then ;      then ;
   
 : name>int ( nfa -- xt ) \ gforth  : name>int ( nt -- xt ) \ gforth
       \G @var{xt} represents the interpretation semantics of the word
       \G @var{nt}. Produces @code{' compile-only-error} if
       \G @var{nt} is compile-only.
     (name>x) (x>int) ;      (name>x) (x>int) ;
   
 : name?int ( nfa -- xt ) \ gforth  : name?int ( nt -- xt ) \ gforth
     \ like name>int, but throws an error if compile-only      \G Like name>int, but throws an error if compile-only.
     (name>x) restrict-mask and      (name>x) restrict-mask and
     if      if
         compile-only-error \ does not return          compile-only-error \ does not return
     then      then
     (cfa>int) ;      (cfa>int) ;
   
 : name>comp ( nfa -- w xt ) \ gforth  : name>comp ( nt -- w xt ) \ gforth
     \ get compilation semantics of name      \G @var{w xt} is the compilation token for the word @var{nt}.
     (name>x) >r dup interpret/compile?      (name>x) >r dup interpret/compile?
     if      if
         interpret/compile-comp @          interpret/compile-comp @
Line 1254  end-struct interpret/compile-struct Line 928  end-struct interpret/compile-struct
         ['] compile,          ['] compile,
     then ;      then ;
   
 : (search-wordlist)  ( addr count wid -- nfa / false )  : (search-wordlist)  ( addr count wid -- nt / false )
     dup wordlist-map @ find-method perform ;      dup wordlist-map @ find-method perform ;
   
 : flag-sign ( f -- 1|-1 )  : flag-sign ( f -- 1|-1 )
Line 1271  end-struct interpret/compile-struct Line 945  end-struct interpret/compile-struct
         (name>intn)          (name>intn)
     then ;      then ;
   
 : find-name ( c-addr u -- nfa/0 )  : find-name ( c-addr u -- nt/0 ) \ gforth
       \g Find the name @var{c-addr u} in the current search
       \g order. Return its nt, if found, otherwise 0.
     lookup @ (search-wordlist) ;      lookup @ (search-wordlist) ;
   
 : sfind ( c-addr u -- 0 / xt +-1  ) \ gforth-obsolete  : sfind ( c-addr u -- 0 / xt +-1  ) \ gforth-obsolete
     find-name dup      find-name dup
     if ( nfa )      if ( nt )
         state @          state @
         if          if
             name>comp ['] execute = flag-sign              name>comp ['] execute = flag-sign
Line 1291  end-struct interpret/compile-struct Line 967  end-struct interpret/compile-struct
         rot drop          rot drop
     then ;      then ;
   
 : (') ( "name" -- nfa ) \ gforth  : (') ( "name" -- nt ) \ gforth
     name find-name dup 0=      name find-name dup 0=
     IF      IF
         drop -&13 bounce          drop -&13 bounce
     THEN  ;      THEN  ;
   
 : [(')]  ( compilation "name" -- ; run-time -- nfa ) \ gforth   bracket-paren-tick  : [(')]  ( compilation "name" -- ; run-time -- nt ) \ gforth    bracket-paren-tick
     (') postpone ALiteral ; immediate restrict      (') postpone ALiteral ; immediate restrict
   
 : '    ( "name" -- xt ) \ core  tick  : '    ( "name" -- xt ) \ core  tick
       \g @var{xt} represents @var{name}'s interpretation
       \g semantics. Performs @code{-14 throw} if the word has no
       \g interpretation semantics.
     (') name?int ;      (') name?int ;
 : [']  ( compilation "name" -- ; run-time -- xt ) \ core        bracket-tick  : [']  ( compilation. "name" -- ; run-time. -- xt ) \ core      bracket-tick
       \g @var{xt} represents @var{name}'s interpretation
       \g semantics. Performs @code{-14 throw} if the word has no
       \g interpretation semantics.
     ' postpone ALiteral ; immediate restrict      ' postpone ALiteral ; immediate restrict
   
 : COMP'    ( "name" -- w xt ) \ gforth  c-tick  : COMP'    ( "name" -- w xt ) \ gforth  c-tick
       \g @var{w xt} represents @var{name}'s compilation semantics.
     (') name>comp ;      (') name>comp ;
 : [COMP']  ( compilation "name" -- ; run-time -- w xt ) \ gforth        bracket-comp-tick  : [COMP']  ( compilation "name" -- ; run-time -- w xt ) \ gforth        bracket-comp-tick
       \g @var{w xt} represents @var{name}'s compilation semantics.
     COMP' swap POSTPONE Aliteral POSTPONE ALiteral ; immediate restrict      COMP' swap POSTPONE Aliteral POSTPONE ALiteral ; immediate restrict
   
 \ reveal words  \ reveal words
Line 1316  Variable warnings ( -- addr ) \ gforth Line 1000  Variable warnings ( -- addr ) \ gforth
 G -1 warnings T !  G -1 warnings T !
   
 : check-shadow  ( addr count wid -- )  : check-shadow  ( addr count wid -- )
 \ prints a warning if the string is already present in the wordlist  \G prints a warning if the string is already present in the wordlist
  >r 2dup 2dup r> (search-wordlist) warnings @ and ?dup if   >r 2dup 2dup r> (search-wordlist) warnings @ and ?dup if
    ." redefined " name>string 2dup type     ." redefined " name>string 2dup type
    compare 0<> if     compare 0<> if
Line 1333  G -1 warnings T ! Line 1017  G -1 warnings T !
     if \ the last word has a header      if \ the last word has a header
         dup ( name>link ) @ 1 and          dup ( name>link ) @ 1 and
         if \ it is still hidden          if \ it is still hidden
             dup ( name>link ) @ 1 xor           ( nfa wid )              dup ( name>link ) @ 1 xor           ( nt wid )
             2dup >r name>string r> check-shadow ( nfa wid )              2dup >r name>string r> check-shadow ( nt wid )
             dup wordlist-map @ reveal-method perform              dup wordlist-map @ reveal-method perform
         then          then
     then ;      then ;
Line 1366  G -1 warnings T ! Line 1050  G -1 warnings T !
     dup IF      dup IF
         #bs emit bl emit #bs emit 1- rot 1- -rot          #bs emit bl emit #bs emit 1- rot 1- -rot
     THEN false ;      THEN false ;
 : (ret)  true space ;  : (ret)  true bl emit ;
   
 Create ctrlkeys  Create ctrlkeys
   ] false false false false  false false false false    ] false false false false  false false false false
Line 1389  defer everychar Line 1073  defer everychar
 : accept   ( addr len -- len ) \ core  : accept   ( addr len -- len ) \ core
   dup 0< IF    abs over dup 1 chars - c@ tuck type     dup 0< IF    abs over dup 1 chars - c@ tuck type 
 \ this allows to edit given strings  \ this allows to edit given strings
          ELSE  0  THEN rot over    ELSE  0  THEN rot over
   BEGIN  key decode  UNTIL    BEGIN  key decode  UNTIL
   2drop nip ;    2drop nip ;
   
 \ Output                                               13feb93py  \ Output                                               13feb93py
   
   has-os [IF]
   0 Value outfile-id ( -- file-id ) \ gforth
   
 : (type) ( c-addr u -- ) \ gforth  : (type) ( c-addr u -- ) \ gforth
     outfile-id write-file drop \ !! use ?DUP-IF THROW ENDIF instead of DROP ?      outfile-id write-file drop \ !! use ?DUP-IF THROW ENDIF instead of DROP ?
 ;  ;
   
 Defer type ( c-addr u -- ) \ core  
 \ defer type for a output buffer or fast  
 \ screen write  
   
 ' (type) IS Type  
   
 : (emit) ( c -- ) \ gforth  : (emit) ( c -- ) \ gforth
     outfile-id emit-file drop \ !! use ?DUP-IF THROW ENDIF instead of DROP ?      outfile-id emit-file drop \ !! use ?DUP-IF THROW ENDIF instead of DROP ?
 ;  ;
   [THEN]
   
   Defer type ( c-addr u -- ) \ core
   ' (type) IS Type
   
 Defer emit ( c -- ) \ core  Defer emit ( c -- ) \ core
 ' (Emit) IS Emit  ' (Emit) IS Emit
Line 1417  Defer key ( -- c ) \ core Line 1102  Defer key ( -- c ) \ core
   
 \ Query                                                07apr93py  \ Query                                                07apr93py
   
   has-files 0= [IF]
   : sourceline# ( -- n )  loadline @ ;
   [THEN]
   
 : refill ( -- flag ) \ core-ext,block-ext,file-ext  : refill ( -- flag ) \ core-ext,block-ext,file-ext
   blk @  IF  1 blk +!  true  0 >in !  EXIT  THEN    blk @  IF  1 blk +!  true  0 >in !  EXIT  THEN
   tib /line    tib /line
   [ has-files [IF] ]
   loadfile @ ?dup    loadfile @ ?dup
   IF    read-line throw    IF    read-line throw
   ELSE  sourceline# 0< IF 2drop false EXIT THEN    ELSE
         accept true  [ [THEN] ]
         sourceline# 0< IF 2drop false EXIT THEN
         accept true
   [ has-files [IF] ]
   THEN    THEN
   [ [THEN] ]
   1 loadline +!    1 loadline +!
   swap #tib ! 0 >in ! ;    swap #tib ! 0 >in ! ;
   
 : Query  ( -- ) \ core-ext  : query   ( -- ) \ core-ext
     \ obsolescent      \G obsolescent
     loadfile off  blk off  refill drop ;      blk off loadfile off
       tib /line accept #tib ! 0 >in ! ;
   
 \ File specifiers                                       11jun93jaw  \ save-mem extend-mem
   
   has-os [IF]
   : save-mem      ( addr1 u -- addr2 u ) \ gforth
       \g copy a memory block into a newly allocated region in the heap
       swap >r
       dup allocate throw
       swap 2dup r> -rot move ;
   
 \ 1 c, here char r c, 0 c,                0 c, 0 c, char b c, 0 c,  : extend-mem    ( addr1 u1 u -- addr addr2 u2 )
 \ 2 c, here char r c, char + c, 0 c,      \ extend memory block allocated from the heap by u aus
 \ 2 c, here char w c, char + c, 0 c, align      \ the (possibly reallocated piece is addr2 u2, the extension is at addr
 4 Constant w/o ( -- fam ) \ file        w-o      over >r + dup >r resize throw
 2 Constant r/w ( -- fam ) \ file        r-w      r> over r> + -rot ;
 0 Constant r/o ( -- fam ) \ file        r-o  [THEN]
   
 \ BIN WRITE-LINE                                        11jun93jaw  
   
 \ : bin           dup 1 chars - c@  
 \                 r/o 4 chars + over - dup >r swap move r> ;  
   
 : bin ( fam1 -- fam2 ) \ file  
     1 or ;  
   
 create nl$ 1 c, A c, 0 c, \ gnu includes usually a cr in dos  
                            \ or not unix environments if  
                            \ bin is not selected  
   
 : write-line ( c-addr u fileid -- ior ) \ file  
     dup >r write-file  
     ?dup IF  
         r> drop EXIT  
     THEN  
     nl$ count r> write-file ;  
   
 \ include-file                                         07apr93py  
   
 : push-file  ( -- )  r>  
   sourceline# >r  loadfile @ >r  
   blk @ >r  tibstack @ >r  >tib @ >r  #tib @ >r  
   >tib @ tibstack @ = IF  r@ tibstack +!  THEN  
   tibstack @ >tib ! >in @ >r  >r ;  
   
 : pop-file   ( throw-code -- throw-code )  
   dup IF  
          source >in @ sourceline# sourcefilename  
          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> tibstack !  r> blk !  
   r> loadfile ! r> loadline !  >r ;  
   
 : read-loop ( i*x -- j*x )  
   BEGIN  refill  WHILE  interpret  REPEAT ;  
   
 : include-file ( i*x fid -- j*x ) \ file  
   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 ;  
   
 : absolut-path? ( addr u -- flag ) \ gforth  
     \ a path is absolute, if it starts with a / or a ~ (~ expansion),  
     \ or if it is in the form ./* or ../*, extended regexp: [/~]|./|../  
     \ Pathes simply containing a / are not absolute!  
     over c@ '/ = >r  
     over c@ '~ = >r  
     2dup 2 min S" ./" compare 0= >r  
          3 min S" ../" compare 0=  
     r> r> r> or or or ;  
 \   [char] / scan nip 0<> ;      
   
 : open-path-file ( c-addr1 u1 -- file-id c-addr2 u2 ) \ gforth  
     \ 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 absolut-path?  
     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 )  
 here ," the terminal" dup c@ swap 1 + swap , A, here 2 cells -  
 create image-included-files  1 , A, ( pointer to and count of included files )  
 \ included-files points to ALLOCATEd space, while image-included-files  
 \ points to ALLOTed objects, so it survives a save-system  
   
 : loadfilename ( -- a-addr )  
     \ a-addr 2@ produces the current file name ( c-addr u )  
     included-files 2@ drop loadfilename# @ 2* cells + ;  
   
 : sourcefilename ( -- c-addr u ) \ gforth  
     \ the name of the source file which is currently the input  
     \ source.  The result is valid only while the file is being  
     \ loaded.  If the current input source is no (stream) file, the  
     \ result is undefined.  
     loadfilename 2@ ;  
   
 : sourceline# ( -- u ) \ gforth         sourceline-number  
     \ the line number of the line that is currently being interpreted  
     \ from a (stream) file. The first line has the number 1. If the  
     \ current input source is no (stream) file, the result is  
     \ undefined.  
     loadline @ ;  
   
 : init-included-files ( -- )  
     image-included-files 2@ 2* cells save-mem drop ( addr )  
     image-included-files 2@ nip included-files 2! ;  
   
 : included? ( c-addr u -- f ) \ gforth  
     \ 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 -- ) \ gforth  
     \ add name c-addr u to included-files  
     included-files 2@ 2* cells 2 cells extend-mem  
     2/ cell / included-files 2!  
     2! ;  
 \    included-files 2@ tuck 1+ 2* cells resize throw  
 \    swap 2dup 1+ included-files 2!  
 \    2* cells + 2! ;  
   
 : included1 ( i*x file-id c-addr u -- j*x ) \ gforth  
     \ include the file file-id with the name given by c-addr u  
     loadfilename# @ >r  
     save-mem add-included-file ( file-id )  
     included-files 2@ nip 1- loadfilename# !  
     ['] include-file catch  
     r> loadfilename# !  
     throw ;  
       
 : included ( i*x addr u -- j*x ) \ file  
     open-path-file included1 ;  
   
 : required ( i*x addr u -- j*x ) \ gforth  
     \ 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 1641  create image-included-files  1 , A, ( po Line 1157  create image-included-files  1 , A, ( po
 : clearstack ( ... -- )  : clearstack ( ... -- )
     s0 @ sp! ;      s0 @ sp! ;
   
 \ INCLUDE                                               9may93jaw  
   
 : include  ( "file" -- ) \ gforth  
   name included ;  
   
 : require  ( "file" -- ) \ gforth  
   name required ;  
   
 \ RECURSE                                               17may93jaw  \ RECURSE                                               17may93jaw
   
 : recurse ( compilation -- ; run-time ?? -- ?? ) \ core  : recurse ( compilation -- ; run-time ?? -- ?? ) \ core
Line 1667  create image-included-files  1 , A, ( po Line 1175  create image-included-files  1 , A, ( po
   
 \ EVALUATE                                              17may93jaw  \ EVALUATE                                              17may93jaw
   
   has-files 0= [IF]
   : push-file  ( -- )  r>
     sourceline# >r  tibstack @ >r  >tib @ >r  #tib @ >r
     >tib @ tibstack @ = IF  r@ tibstack +!  THEN
     tibstack @ >tib ! >in @ >r  >r ;
   
   : pop-file   ( throw-code -- throw-code )
     r>
     r> >in !  r> #tib !  r> >tib !  r> tibstack !  r> loadline !  >r ;
   [THEN]
   
 : evaluate ( c-addr len -- ) \ core,block  : evaluate ( c-addr len -- ) \ core,block
   push-file  #tib ! >tib !    push-file  #tib ! >tib !
   >in off blk off loadfile off -1 loadline !    >in off blk off loadfile off -1 loadline !
Line 1684  create image-included-files  1 , A, ( po Line 1203  create image-included-files  1 , A, ( po
 Defer 'quit  Defer 'quit
 Defer .status  Defer .status
 : prompt        state @ IF ."  compiled" EXIT THEN ."  ok" ;  : prompt        state @ IF ."  compiled" EXIT THEN ."  ok" ;
 : (quit)        BEGIN .status cr query interpret prompt AGAIN ;  : (Query)  ( -- )
       loadfile off  blk off  refill drop ;
   : (quit)  BEGIN  .status cr (query) interpret prompt  AGAIN ;
 ' (quit) IS 'quit  ' (quit) IS 'quit
   
 \ DOERROR (DOERROR)                                     13jun93jaw  \ DOERROR (DOERROR)                                     13jun93jaw
Line 1709  max-errors 6 * cells allot Line 1230  max-errors 6 * cells allot
 : typewhite ( addr u -- ) \ gforth  : typewhite ( addr u -- ) \ gforth
     \ like type, but white space is printed instead of the characters      \ like type, but white space is printed instead of the characters
     bounds ?do      bounds ?do
         i c@ 9 = if \ check for tab          i c@ #tab = if \ check for tab
             9              #tab
         else          else
             bl              bl
         then          then
Line 1780  DEFER DOERROR Line 1301  DEFER DOERROR
 \ : .name ( name -- ) name>string type space ;  \ : .name ( name -- ) name>string type space ;
 \ : words  listwords @  \ : words  listwords @
 \          BEGIN  @ dup  WHILE  dup .name  REPEAT drop ;  \          BEGIN  @ dup  WHILE  dup .name  REPEAT drop ;
   
 : cstring>sstring  ( cstring -- addr n ) \ gforth       cstring-to-sstring  
     -1 0 scan 0 swap 1+ /string ;  
 : arg ( n -- addr count ) \ gforth  
     cells argv @ + @ cstring>sstring ;  
 : #!       postpone \ ;  immediate  
   
 Create pathstring 2 cells allot \ string  
 Create pathdirs   2 cells allot \ dir string array, pointer and count  
 Variable argv  
 Variable argc  
   
 0 Value script? ( -- flag )  
   
 : process-path ( addr1 u1 -- addr2 u2 )  
     \ addr1 u1 is a path string, addr2 u2 is an array of dir strings  
     align here >r  
     BEGIN  
         over >r [char] : scan  
         over r> tuck - ( rest-str this-str )  
         dup  
         IF  
             2dup 1- chars + c@ [char] / <>  
             IF  
                 2dup chars + [char] / swap c!  
                 1+  
             THEN  
             2,  
         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  Defer 'cold ' noop IS 'cold
   
 : cold ( -- ) \ gforth  : cold ( -- ) \ gforth
     stdout TO outfile-id  [ has-files [IF] ]
     pathstring 2@ process-path pathdirs 2!      pathstring 2@ process-path pathdirs 2!
     init-included-files      init-included-files
   [ [THEN] ]
     'cold      'cold
   [ has-files [IF] ]
     argc @ 1 >      argc @ 1 >
     IF      IF
         true to script?  
         ['] process-args catch ?dup          ['] process-args catch ?dup
         IF          IF
             dup >r DoError cr r> negate (bye)              dup >r DoError cr r> negate (bye)
         THEN          THEN
         cr          cr
     THEN      THEN
     false to script?  [ [THEN] ]
     ." GForth " version-string type ." , Copyright (C) 1994-1996 Free Software Foundation, Inc." cr      ." GForth " version-string type ." , Copyright (C) 1994-1996 Free Software Foundation, Inc." cr
     ." GForth comes with ABSOLUTELY NO WARRANTY; for details type `license'" cr      ." GForth comes with ABSOLUTELY NO WARRANTY; for details type `license'"
     ." Type `bye' to exit"  [ has-os [IF] ]
        cr ." Type `bye' to exit"
   [ [THEN] ]
     loadline off quit ;      loadline off quit ;
   
 : license ( -- ) \ gforth  : license ( -- ) \ gforth
Line 1880  Defer 'cold ' noop IS 'cold Line 1343  Defer 'cold ' noop IS 'cold
  ." Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA." cr ;   ." Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA." cr ;
   
 : boot ( path **argv argc -- )  : boot ( path **argv argc -- )
   argc ! argv ! cstring>sstring pathstring 2!  main-task up!      main-task up!
   sp@ dup s0 ! $10 + dup >tib ! tibstack ! #tib off >in off  [ has-os [IF] ]
   rp@ r0 !  fp@ f0 !  ['] cold catch DoError bye ;      stdout TO outfile-id
   [ [THEN] ]
   [ has-files [IF] ]
       argc ! argv ! pathstring 2!
   [ [THEN] ]
       sp@ s0 !
   [ has-locals [IF] ]
       lp@ forthstart 7 cells + @ - 
   [ [ELSE] ]
       [ has-os [IF] ]
       sp@ $1040 +
       [ [ELSE] ]
       sp@ $40 +
       [ [THEN] ]
   [ [THEN] ]
       dup >tib ! tibstack ! #tib off >in off
       rp@ r0 !
   [ has-floats [IF] ]
       fp@ f0 !
   [ [THEN] ]
       ['] cold catch DoError
   [ has-os [IF] ]
       bye
   [ [THEN] ]
   ;
   
   has-os [IF]
 : bye ( -- ) \ tools-ext  : bye ( -- ) \ tools-ext
     script? 0= IF  cr  THEN  0 (bye) ;  [ has-files [IF] ]
       script? 0= IF  cr  THEN
   [ [ELSE] ]
       cr
   [ [THEN] ]
       0 (bye) ;
   [THEN]
   
 \ **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.2  
changed lines
  Added in v.1.17


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