[BACK]Return to kernel.fs CVS log [TXT] [DIR] Up to [gforth] / gforth

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

version 1.4, 1996/09/30 13:16:11 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
Line 76  HEX Line 50  HEX
   
 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  
     \g 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" -- ) \ gforth  : interpret/compile: ( interp-xt comp-xt "name" -- ) \ gforth
     Create immediate swap A, A,      Create immediate swap A, A,
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
       'catch
     sp@ >r      sp@ >r
     fp@ >r      fp@ >r
     lp@ >r      lp@ >r
Line 483  hex Line 471  hex
         r> lp!          r> lp!
         r> fp!          r> fp!
         r> swap >r sp! drop r>          r> swap >r sp! drop r>
           'throw
     THEN ;      THEN ;
   
 \ Bouncing is very fine,  \ Bouncing is very fine,
Line 495  hex Line 484  hex
       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 573  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  ;
   
 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  
       
 \ 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  
 \G This is the preferred alternative to the idiom "?DUP IF", since it can be  
 \G 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  
   
 Defer then-like ( orig -- addr )  
 : cs>addr ( orig/dest -- addr )  drop nip ;  
 ' cs>addr IS then-like  
   
 : 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  
   
 Defer begin-like ( -- )  
 ' noop IS begin-like  
   
 : BEGIN ( compilation -- dest ; run-time -- ) \ core  
     begin-like cs-push-part dest ; immediate restrict  
   
 Defer again-like ( dest -- addr )  
 ' nip IS again-like  
   
 : AGAIN ( compilation dest -- ; run-time -- ) \ core-ext  
     dest? again-like  POSTPONE branch  <resolve ; immediate restrict  
   
 Defer until-like  
 : until, ( list addr xt1 xt2 -- )  drop compile, <resolve drop ;  
 ' until, IS until-like  
   
 : 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  
   
 Defer exit-like ( -- )  
 ' noop IS exit-like  
   
 : EXIT ( compilation -- ; run-time nest-sys -- ) \ core  
     exit-like  
     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 870  Defer exit-like ( -- ) Line 575  Defer exit-like ( -- )
     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 1150  end-struct interpret/compile-struct Line 850  end-struct interpret/compile-struct
     (cfa>int) ;      (cfa>int) ;
   
 : name>comp ( nt -- w xt ) \ gforth  : name>comp ( nt -- w xt ) \ gforth
     \G @var{w xt} is the compilation token wor the word @var{nt}.      \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 1345  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
     \G 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
   
   : 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  
   
 \ 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  
     \G a path is absolute, if it starts with a / or a ~ (~ expansion),  
     \G or if it is in the form ./* or ../*, extended regexp: ^[/~]|./|../  
     \G 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  
     \G opens a file for reading, searching in the path for it (unless  
     \G the filename contains a slash); c-addr2 u2 is the full filename  
     \G (valid until the next call); if the file is not found (or in  
     \G case of other errors for each try), -38 (non-existant file) is  
     \G thrown. Opening for other access modes makes little sense, as  
     \G the path will usually contain dirs that are only readable for  
     \G 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 )  
     \G a-addr 2@ produces the current file name ( c-addr u )  
     included-files 2@ drop loadfilename# @ 2* cells + ;  
   
 : sourcefilename ( -- c-addr u ) \ gforth  
     \G the name of the source file which is currently the input  
     \G source.  The result is valid only while the file is being  
     \G loaded.  If the current input source is no (stream) file, the  
     \G result is undefined.  
     loadfilename 2@ ;  
   
 : sourceline# ( -- u ) \ gforth         sourceline-number  
     \G the line number of the line that is currently being interpreted  
     \G from a (stream) file. The first line has the number 1. If the  
     \G current input source is no (stream) file, the result is  
     \G 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  
     \G 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  
     \G 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  
     \G 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  
     \G include the file with the name given by addr u, if it is not  
     \G included already. Currently this works by comparing the name of  
     \G the file (with path) against the names of earlier included  
     \G files; however, it would probably be better to fstat the file,  
     \G and compare the device and inode. The advantages would be: no  
     \G problems with several paths to the same file (e.g., due to  
     \G links) and we would catch files included with include-file and  
     \G write a require-file.  
     open-path-file 2dup included?  
     if  
         2drop close-file throw  
     else  
         included1  
     then ;  
   
 \ HEX DECIMAL                                           2may93jaw  \ HEX DECIMAL                                           2may93jaw
   
Line 1558  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 1601  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 1626  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 1697  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 1767  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 1797  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 save-mem 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.4  
changed lines
  Added in v.1.13

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