Diff for /gforth/Attic/kernel.fs between versions 1.6 and 1.15

version 1.6, 1996/10/02 09:48:58 version 1.15, 1997/02/09 21:51:39
Line 20 Line 20
   
 \ Idea and implementation: Bernd Paysan (py)  \ Idea and implementation: Bernd Paysan (py)
   
 \ Log:  ', '- usw. durch [char] ... ersetzt  
 \       man sollte die unterschiedlichen zahlensysteme  
 \       mit $ und & zumindest im interpreter weglassen  
 \       schon erledigt!  
 \       11may93jaw  
 \ name>         0= nicht vorhanden              17may93jaw  
 \               nfa can be lfa or nfa!  
 \ find          splited into find and (find)  
 \               (find) for later use            17may93jaw  
 \ search        replaced by lookup because  
 \               it is a word of the string wordset  
 \                                               20may93jaw  
 \ postpone      added immediate                 21may93jaw  
 \ to            added immediate                 07jun93jaw  
 \ cfa, header   put "here lastcfa !" in  
 \               cfa, this is more logical  
 \               and noname: works wothout  
 \               extra "here lastcfa !"          08jun93jaw  
 \ (parse-white) thrown out  
 \ refill        added outer trick  
 \               to show there is something  
 \               going on                        09jun93jaw  
 \ leave ?leave  somebody forgot UNLOOP!!!       09jun93jaw  
 \ leave ?leave  unloop thrown out  
 \               unloop after loop is used       10jun93jaw  
   
 HEX  HEX
   
 \ labels for some code addresses  \ labels for some code addresses
   
   doer? :docon [IF]
 : docon: ( -- addr )    \ gforth  : docon: ( -- addr )    \ gforth
     \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 118  NIL AConstant NIL \ gforth Line 112  NIL AConstant NIL \ gforth
     LOOP ;      LOOP ;
   
 \ !! this is machine-dependent, but works on all but the strangest machines  \ !! this is machine-dependent, but works on all but the strangest machines
 ' faligned Alias maxaligned ( addr1 -- addr2 ) \ gforth  
 ' falign Alias maxalign ( -- ) \ gforth  : maxaligned ( addr -- f-addr ) \ float
       [ /maxalign 1 - ] Literal + [ 0 /maxalign - ] Literal and ;
   : maxalign ( -- ) \ float
       here dup maxaligned swap
       ?DO
           bl c,
       LOOP ;
   
 \ !! machine-dependent and won't work if "0 >body" <> "0 >body maxaligned"  \ !! machine-dependent and won't work if "0 >body" <> "0 >body maxaligned"
 ' maxaligned Alias cfaligned ( addr1 -- addr2 ) \ gforth  ' maxaligned Alias cfaligned ( addr1 -- addr2 ) \ gforth
Line 178  $20 constant restrict-mask Line 178  $20 constant restrict-mask
 : bounds ( beg count -- end beg ) \ gforth  : bounds ( beg count -- end beg ) \ gforth
     over + swap ;      over + swap ;
   
 : save-mem      ( addr1 u -- addr2 u ) \ gforth  
     \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 441  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 474  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 490  hex Line 491  hex
     ?DUP IF      ?DUP IF
         [ here 9 cells ! ] \ entry point for signal handler          [ here 9 cells ! ] \ 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 506  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 @ > 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 587  Defer interpreter-notfound ( c-addr coun Line 605  Defer interpreter-notfound ( c-addr coun
 : ] ( -- ) \ core       right-bracket  : ] ( -- ) \ core       right-bracket
     ['] compiler     IS parser state on  ;      ['] compiler     IS parser state on  ;
   
 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 884  Defer exit-like ( -- ) Line 617  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 1023  Create ???  0 , 3 c, char ? c, char ? c, Line 751  Create ???  0 , 3 c, char ? c, char ? c,
 : dodoes,  ( -- )  : dodoes,  ( -- )
   here /does-handler allot does-handler! ;    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 1032  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 1048  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 1055  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 1164  end-struct interpret/compile-struct Line 917  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 1297  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 1320  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 1348  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
     loadfile off  blk off  refill drop ;      blk off loadfile off
       tib /line accept #tib ! 0 >in ! ;
 \ File specifiers                                       11jun93jaw  
   
   
 \ 1 c, here char r c, 0 c,                0 c, 0 c, char b c, 0 c,  
 \ 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@  \ save-mem extend-mem
 \                 r/o 4 chars + over - dup >r swap move r> ;  
   
 : bin ( fam1 -- fam2 ) \ file  has-os [IF]
     1 or ;  : save-mem      ( addr1 u -- addr2 u ) \ gforth
       \g copy a memory block into a newly allocated region in the heap
 create nl$ 1 c, A c, 0 c, \ gnu includes usually a cr in dos      swap >r
                            \ or not unix environments if      dup allocate throw
                            \ bin is not selected      swap 2dup r> -rot move ;
   
 : 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  : 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 1572  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 1598  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 1615  create image-included-files  1 , A, ( po Line 1203  create image-included-files  1 , A, ( po
 Defer 'quit  Defer 'quit
 Defer .status  Defer .status
 : prompt        state @ IF ."  compiled" EXIT THEN ."  ok" ;  : prompt        state @ IF ."  compiled" EXIT THEN ."  ok" ;
 : (quit)        BEGIN .status cr query interpret prompt AGAIN ;  : (Query)  ( -- )
       loadfile off  blk off  refill drop ;
   : (quit)  BEGIN  .status cr (query) interpret prompt  AGAIN ;
 ' (quit) IS 'quit  ' (quit) IS 'quit
   
 \ DOERROR (DOERROR)                                     13jun93jaw  \ DOERROR (DOERROR)                                     13jun93jaw
Line 1640  max-errors 6 * cells allot Line 1230  max-errors 6 * cells allot
 : typewhite ( addr u -- ) \ gforth  : typewhite ( addr u -- ) \ gforth
     \ like type, but white space is printed instead of the characters      \ like type, but white space is printed instead of the characters
     bounds ?do      bounds ?do
         i c@ 9 = if \ check for tab          i c@ #tab = if \ check for tab
             9              #tab
         else          else
             bl              bl
         then          then
Line 1711  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 1811  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 ! save-mem pathstring 2!  main-task up!      main-task up!
   sp@ dup s0 ! $10 + dup >tib ! tibstack ! #tib off >in off  [ has-os [IF] ]
   rp@ r0 !  fp@ f0 !  ['] cold catch DoError bye ;      stdout TO outfile-id
   [ [THEN] ]
   [ has-files [IF] ]
       argc ! argv ! pathstring 2!
   [ [THEN] ]
       sp@ s0 !
   [ has-locals [IF] ]
       lp@ forthstart 7 cells + @ - 
   [ [ELSE] ]
       [ has-os [IF] ]
       sp@ $1040 +
       [ [ELSE] ]
       sp@ $40 +
       [ [THEN] ]
   [ [THEN] ]
       dup >tib ! tibstack ! #tib off >in off
       rp@ r0 !
   [ has-floats [IF] ]
       fp@ f0 !
   [ [THEN] ]
       ['] cold catch DoError
   [ has-os [IF] ]
       bye
   [ [THEN] ]
   ;
   
   has-os [IF]
 : bye ( -- ) \ tools-ext  : bye ( -- ) \ tools-ext
     script? 0= IF  cr  THEN  0 (bye) ;  [ has-files [IF] ]
       script? 0= IF  cr  THEN
   [ [ELSE] ]
       cr
   [ [THEN] ]
       0 (bye) ;
   [THEN]
   
 \ **argv may be scanned by the C starter to get some important  \ **argv may be scanned by the C starter to get some important
 \ information, as -display and -geometry for an X client FORTH  \ information, as -display and -geometry for an X client FORTH

Removed from v.1.6  
changed lines
  Added in v.1.15


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