Diff for /gforth/Attic/kernel.fs between versions 1.10 and 1.21

version 1.10, 1997/01/04 16:32:30 version 1.21, 1997/03/25 23:27:13
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@ ( -- w ; R: w -- w ) \ core r-fetch
   \ copy w from the return stack to the data stack
   
 \ 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 113  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 179  $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 250  Defer source ( -- addr count ) \ core Line 265  Defer source ( -- addr count ) \ core
 : (compile) ( -- ) \ gforth  : (compile) ( -- ) \ gforth
     r> dup cell+ >r @ compile, ;      r> dup cell+ >r @ compile, ;
   
 : postpone, ( w xt -- )  : postpone, ( w xt -- ) \ gforth postpone-comma
     \g Compiles the compilation semantics represented by @var{w xt}.      \g Compiles the compilation semantics represented by @var{w xt}.
     dup ['] execute =      dup ['] execute =
     if      if
Line 415  hex Line 430  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 463  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 490  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 517  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 @ > IF    -4 throw  THEN      sp@ s0 @ u> IF    -4 throw  THEN
     fp@ f0 @ > IF  -&45 throw  THEN  ;  [ has-floats [IF] ]
       fp@ f0 @ u> IF  -&45 throw  THEN
   [ [THEN] ]
   ;
 \ ?stack should be code -- it touches an empty stack!  \ ?stack should be code -- it touches an empty stack!
   
 \ interpret                                            10mar92py  \ interpret                                            10mar92py
Line 561  Defer interpreter-notfound ( c-addr coun Line 606  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 858  Defer exit-like ( -- ) Line 618  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 993  Create ???  0 , 3 c, char ? c, char ? c, Line 748  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 1006  Create ???  0 , 3 c, char ? c, char ? c, Line 766  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 1022  Create ???  0 , 3 c, char ? c, char ? c, Line 793  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 1029  Create ???  0 , 3 c, char ? c, char ? c, Line 802  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 1182  end-struct interpret/compile-struct Line 962  end-struct interpret/compile-struct
         then          then
     then ;      then ;
   
 : find ( c-addr -- xt +-1 / c-addr 0 ) \ core  : find ( c-addr -- xt +-1 / c-addr 0 ) \ core,search
     dup count sfind dup      dup count sfind dup
     if      if
         rot drop          rot drop
Line 1258  G -1 warnings T ! Line 1038  G -1 warnings T !
 0C constant #ff ( -- c ) \ gforth  0C constant #ff ( -- c ) \ gforth
 0A constant #lf ( -- c ) \ gforth  0A constant #lf ( -- c ) \ gforth
   
 : bell  #bell emit ;  : bell ( -- ) \ gforth
       \g makes a beep and flushes the output buffer
       #bell emit
       outfile-id flush-file drop ;
 : cr ( -- ) \ core  : cr ( -- ) \ core
     \ emit a newline      \ emit a newline
     #lf ( sic! ) emit ;      #lf ( sic! ) emit ;
Line 1271  G -1 warnings T ! Line 1054  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 1294  defer everychar Line 1077  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 1322  Defer key ( -- c ) \ core Line 1106  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 )  
   BEGIN  refill  WHILE  interpret  REPEAT ;  
   
 : include-file ( i*x fid -- j*x ) \ file  has-os [IF]
   push-file  loadfile !  : save-mem      ( addr1 u -- addr2 u ) \ gforth
   0 loadline ! blk off  ['] read-loop catch      \g copy a memory block into a newly allocated region in the heap
   loadfile @ close-file swap 2dup or      swap >r
   pop-file  drop throw throw ;      dup allocate throw
       swap 2dup r> -rot move ;
 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 1542  create image-included-files  1 , A, ( po Line 1161  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 1568  create image-included-files  1 , A, ( po Line 1179  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 1587  Defer .status Line 1209  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 1643  DEFER DOERROR Line 1265  DEFER DOERROR
 ;  ;
   
 : (DoError) ( throw-code -- )  : (DoError) ( throw-code -- )
     [ has-os [IF] ] outfile-id >r  stderr to outfile-id [ [THEN] ] 
   sourceline# IF    sourceline# IF
                source >in @ sourceline# 0 0 .error-frame                 source >in @ sourceline# 0 0 .error-frame
   THEN    THEN
Line 1664  DEFER DOERROR Line 1287  DEFER DOERROR
   ELSE    ELSE
      .error       .error
   THEN    THEN
   normal-dp dpp ! ;    normal-dp dpp !
     [ has-os [IF] ] r> to outfile-id [ [THEN] ] 
   ;
   
 ' (DoError) IS DoError  ' (DoError) IS DoError
   
Line 1683  DEFER DOERROR Line 1308  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 ;
   Defer 'cold ( -- ) \ gforth tick-cold
 : cstring>sstring  ( cstring -- addr n ) \ gforth       cstring-to-sstring  \ hook (deferred word) for things to do right before interpreting the
     -1 0 scan 0 swap 1+ /string ;  \ command-line arguments
 : arg ( n -- addr count ) \ gforth  ' noop IS 'cold
     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  
   
 : 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 1783  Defer 'cold ' noop IS 'cold Line 1353  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.10  
changed lines
  Added in v.1.21


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