Diff for /gforth/Attic/kernel.fs between versions 1.1 and 1.13

version 1.1, 1996/09/19 22:17:34 version 1.13, 1997/02/06 21:23:01
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
   
 : 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 ;
   
 : docol: ( -- addr )    \ gforth  : docol: ( -- addr )    \ gforth
     \ the code address of a colon definition      \G the code address of a colon definition
     ['] docon: >code-address ;      ['] docon: >code-address ;
   
 : 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 ;
   
 : 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 ;
   
 : 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 ;
   
 : 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 ;
   
 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 178  $20 constant restrict-mask Line 156  $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 242  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" -- )  : interpret/compile: ( interp-xt comp-xt "name" -- ) \ gforth
     Create immediate swap A, A,      Create immediate swap A, A,
 DOES>  DOES>
     abort" executed primary cfa of an interpret/compile: word" ;      abort" executed primary cfa of an interpret/compile: word" ;
Line 325  DOES> Line 305  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 463  hex Line 443  hex
 : lp@ ( -- addr ) \ gforth      l-p-fetch  : lp@ ( -- addr ) \ gforth      l-p-fetch
  laddr# [ 0 , ] ;   laddr# [ 0 , ] ;
   
   Defer 'catch
   Defer 'throw
   Defer 'bounce
   
   ' 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      fp@ >r
   handler @ >r      lp@ >r
   rp@ handler !      handler @ >r
   execute      rp@ handler !
   r> handler ! rdrop rdrop rdrop 0 ;      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 ! ]          [ here 9 cells ! ] \ entry point for signal handler
         handler @ rp!          handler @ dup 0= IF
               2 (bye)
           THEN
           rp!
         r> handler !          r> handler !
         r> lp!          r> lp!
         r> fp!          r> fp!
         r> swap >r sp! r>          r> swap >r sp! drop r>
           'throw
     THEN ;      THEN ;
   
 \ Bouncing is very fine,  \ Bouncing is very fine,
Line 487  hex Line 479  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!        r> lp!
     rdrop        rdrop
     rdrop        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  ;      fp@ f0 @ u> 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
Line 546  Defer interpreter-notfound ( c-addr coun Line 539  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 563  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 575  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 1011  Avariable leave-sp  leave-stack 3 cells Line 614  Avariable leave-sp  leave-stack 3 cells
     \ aborts if the last defined word was headerless      \ aborts if the last defined word was headerless
     last @ dup 0= abort" last word was headerless" cell+ ;      last @ dup 0= abort" last word was headerless" cell+ ;
   
 : immediate     immediate-mask lastflags cset ;  : immediate ( -- ) \ core
 : restrict      restrict-mask lastflags cset ;      immediate-mask lastflags cset ;
   : restrict ( -- ) \ gforth
       restrict-mask lastflags cset ;
   ' restrict alias compile-only ( -- ) \ gforth
   
 \ Header                                               23feb93py  \ Header                                               23feb93py
   
Line 1025  defer header ( -- ) \ gforth Line 631  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 1039  defer header ( -- ) \ gforth Line 645  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 1075  create nextname-buffer 32 chars allot Line 681  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 1121  Create ???  0 , 3 c, char ? c, char ? c, Line 728  Create ???  0 , 3 c, char ? c, char ? c,
   
 : (Constant)  Header reveal docon: cfa, ;  : (Constant)  Header reveal docon: cfa, ;
 : Constant ( w "name" -- ) \ core  : Constant ( w "name" -- ) \ core
       \G Defines constant @var{name}
       \G  
       \G @var{name} execution: @var{-- w}
     (Constant) , ;      (Constant) , ;
 : AConstant ( addr "name" -- ) \ gforth  : AConstant ( addr "name" -- ) \ gforth
     (Constant) A, ;      (Constant) A, ;
Line 1165  AVariable current ( -- addr ) \ gforth Line 775  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 1175  AVariable current ( -- addr ) \ gforth Line 785  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 1188  struct Line 798  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 1225  end-struct interpret/compile-struct Line 835  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 1248  end-struct interpret/compile-struct Line 861  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 1265  end-struct interpret/compile-struct Line 878  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 1285  end-struct interpret/compile-struct Line 900  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 1310  Variable warnings ( -- addr ) \ gforth Line 933  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 1327  G -1 warnings T ! Line 950  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 1422  Defer key ( -- c ) \ core Line 1045  Defer key ( -- c ) \ core
   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  
   
   
 \ 1 c, here char r c, 0 c,                0 c, 0 c, char b c, 0 c,  \ save-mem extend-mem
 \ 2 c, here char r c, char + c, 0 c,  
 \ 2 c, here char w c, char + c, 0 c, align  
 4 Constant w/o ( -- fam ) \ file        w-o  
 2 Constant r/w ( -- fam ) \ file        r-w  
 0 Constant r/o ( -- fam ) \ file        r-o  
   
 \ BIN WRITE-LINE                                        11jun93jaw  : save-mem      ( addr1 u -- addr2 u ) \ gforth
       \g copy a memory block into a newly allocated region in the heap
 \ : bin           dup 1 chars - c@      swap >r
 \                 r/o 4 chars + over - dup >r swap move r> ;      dup allocate throw
       swap 2dup r> -rot move ;
 : 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  : extend-mem    ( addr1 u1 u -- addr addr2 u2 )
     \ include the file with the name given by addr u, if it is not      \ extend memory block allocated from the heap by u aus
     \ included already. Currently this works by comparing the name of      \ the (possibly reallocated piece is addr2 u2, the extension is at addr
     \ the file (with path) against the names of earlier included      over >r + dup >r resize throw
     \ files; however, it would probably be better to fstat the file,      r> over r> + -rot ;
     \ 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 1635  create image-included-files  1 , A, ( po Line 1078  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 1678  create image-included-files  1 , A, ( po Line 1113  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 1703  max-errors 6 * cells allot Line 1140  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 1774  DEFER DOERROR Line 1211  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
Line 1844  Defer 'cold ' noop IS 'cold Line 1220  Defer 'cold ' noop IS 'cold
     'cold      'cold
     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?  
     ." 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'" cr
     ." Type `bye' to exit"      ." Type `bye' to exit"
Line 1874  Defer 'cold ' noop IS 'cold Line 1248  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!    argc ! argv ! pathstring 2!  main-task up!
   sp@ dup s0 ! $10 + dup >tib ! tibstack ! #tib off >in off    sp@ s0 !
   rp@ r0 !  fp@ f0 !  ['] cold catch DoError bye ;    lp@ forthstart 7 cells + @ - dup >tib ! tibstack ! #tib off >in off
     rp@ r0 !
     fp@ f0 !
     ['] cold catch DoError
     bye ;
   
 : bye ( -- ) \ tools-ext  : bye ( -- ) \ tools-ext
     script? 0= IF  cr  THEN  0 (bye) ;      script? 0= IF  cr  THEN  0 (bye) ;

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


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