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

version 1.11, 1997/01/29 21:32:36 version 1.17, 1997/03/04 22:09:54
Line 24  HEX Line 24  HEX
   
 \ labels for some code addresses  \ labels for some code addresses
   
   doer? :docon [IF]
 : docon: ( -- addr )    \ gforth  : docon: ( -- addr )    \ gforth
     \G 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
     \G 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
     \G 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
     \G 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
     \G 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
     \G 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 92  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 152  $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  
     \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 415  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 448  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
       'catch
     sp@ >r      sp@ >r
   [ has-floats [IF] ]
     fp@ >r      fp@ >r
   [ [THEN] ]
   [ has-locals [IF] ]
     lp@ >r      lp@ >r
   [ [THEN] ]
     handler @ >r      handler @ >r
     rp@ handler !      rp@ handler !
     execute      execute
Line 462  hex Line 489  hex
   
 : 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 ! ] \ entry point for signal handler          [ has-header [IF] here 9 cells ! [THEN] ] \ entry point for signal handler
         handler @ dup 0= IF          handler @ dup 0= IF
   [ has-os [IF] ]
             2 (bye)              2 (bye)
   [ [ELSE] ]
               quit
   [ [THEN] ]
         THEN          THEN
         rp!          rp!
         r> handler !          r> handler !
         r> lp!  [ has-locals [IF] ]
           r> lp!
   [ [THEN] ]
   [ has-floats [IF] ]
         r> fp!          r> fp!
   [ [THEN] ]
         r> swap >r sp! drop r>          r> swap >r sp! drop r>
           'throw
     THEN ;      THEN ;
   
 \ Bouncing is very fine,  \ Bouncing is very fine,
Line 480  hex Line 516  hex
   ?DUP IF    ?DUP IF
       handler @ rp!        handler @ rp!
       r> handler !        r> handler !
   [ has-locals [IF] ]
       r> lp!        r> lp!
   [ [THEN] ]
   [ has-floats [IF] ]
       rdrop        rdrop
   [ [THEN] ]
       rdrop        rdrop
         'throw
   THEN ;    THEN ;
   
 \ ?stack                                               23feb93py  \ ?stack                                               23feb93py
   
 : ?stack ( ?? -- ?? ) \ gforth  : ?stack ( ?? -- ?? ) \ gforth
     sp@ s0 @ u> IF    -4 throw  THEN      sp@ s0 @ u> IF    -4 throw  THEN
     fp@ f0 @ u> 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 573  Defer interpreter-notfound ( c-addr coun Line 617  Defer interpreter-notfound ( c-addr coun
     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 708  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 721  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  
Line 737  Create ???  0 , 3 c, char ? c, char ? c, Line 792  Create ???  0 , 3 c, char ? c, char ? c,
     (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 744  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 986  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 1009  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 1037  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
     \G obsolescent      \G obsolescent
       blk off loadfile off
     tib /line accept #tib ! 0 >in ! ;      tib /line accept #tib ! 0 >in ! ;
   
 \ File specifiers                                       11jun93jaw  \ save-mem extend-mem
   
   
 \ 1 c, here char r c, 0 c,                0 c, 0 c, char b c, 0 c,  
 \ 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  
   
 \ : bin           dup 1 chars - c@  
 \                 r/o 4 chars + over - dup >r swap move r> ;  
   
 : bin ( fam1 -- fam2 ) \ file  
     1 or ;  
   
 : write-line ( c-addr u fileid -- ior ) \ file  
     dup >r write-file  
     ?dup IF  
         r> drop EXIT  
     THEN  
     #lf r> emit-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 )  has-os [IF]
   BEGIN  refill  WHILE  interpret  REPEAT ;  : save-mem      ( addr1 u -- addr2 u ) \ gforth
       \g copy a memory block into a newly allocated region in the heap
 : include-file ( i*x fid -- j*x ) \ file      swap >r
   push-file  loadfile !      dup allocate throw
   0 loadline ! blk off  ['] read-loop catch      swap 2dup r> -rot move ;
   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  : extend-mem    ( addr1 u1 u -- addr addr2 u2 )
     \G include the file with the name given by addr u, if it is not      \ extend memory block allocated from the heap by u aus
     \G included already. Currently this works by comparing the name of      \ the (possibly reallocated piece is addr2 u2, the extension is at addr
     \G the file (with path) against the names of earlier included      over >r + dup >r resize throw
     \G files; however, it would probably be better to fstat the file,      r> over r> + -rot ;
     \G and compare the device and inode. The advantages would be: no  [THEN]
     \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 1257  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 1283  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 1302  Defer .status Line 1205  Defer .status
 : prompt        state @ IF ."  compiled" EXIT THEN ."  ok" ;  : prompt        state @ IF ."  compiled" EXIT THEN ."  ok" ;
 : (Query)  ( -- )  : (Query)  ( -- )
     loadfile off  blk off  refill drop ;      loadfile off  blk off  refill drop ;
 : (quit)        BEGIN .status cr (query) interpret prompt AGAIN ;  : (quit)  BEGIN  .status cr (query) interpret prompt  AGAIN ;
 ' (quit) IS 'quit  ' (quit) IS 'quit
   
 \ DOERROR (DOERROR)                                     13jun93jaw  \ DOERROR (DOERROR)                                     13jun93jaw
Line 1398  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 0 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 1498  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 ! pathstring 2!  main-task up!      main-task up!
   sp@ s0 !  [ has-os [IF] ]
   lp@ forthstart 7 cells + @ - dup >tib ! tibstack ! #tib off >in off      stdout TO outfile-id
   rp@ r0 !  [ [THEN] ]
   fp@ f0 !  [ has-files [IF] ]
   ['] cold catch DoError      argc ! argv ! pathstring 2!
   bye ;  [ [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.11  
changed lines
  Added in v.1.17


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