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

Diff for /gforth/Attic/kernal.fs between versions 1.46 and 1.63

version 1.46, 1995/11/07 18:06:47 version 1.63, 1996/09/10 16:08:39
Line 74  HEX Line 74  HEX
     \ the code address of a @code{field}      \ the code address of a @code{field}
     ['] reveal-method >code-address ;      ['] reveal-method >code-address ;
   
   NIL AConstant NIL \ gforth
   
 \ 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,
 DOES> ( n -- )  + c@ ;  \ DOES> ( n -- )  + c@ ;
   
 : >bit  ( addr n -- c-addr mask )  8 /mod rot + swap bits ;  \ : >bit  ( addr n -- c-addr mask )  8 /mod rot + swap bits ;
 : +bit  ( addr n -- )  >bit over c@ or swap c! ;  \ : +bit  ( addr n -- )  >bit over c@ or swap c! ;
   
 : relinfo ( -- addr )  forthstart dup @ + ;  \ : relinfo ( -- addr )  forthstart dup @ + !!bug!! ;
 : >rel  ( addr -- n )  forthstart - ;  \ : >rel  ( addr -- n )  forthstart - ;
 : relon ( addr -- )  relinfo swap >rel cell / +bit ;  \ : relon ( addr -- )  relinfo swap >rel cell / +bit ;
   
 \ here allot , c, A,                                   17dec92py  \ here allot , c, A,                                   17dec92py
   
Line 128  DOES> ( n -- )  + c@ ; Line 130  DOES> ( n -- )  + c@ ;
 ; immediate  ; immediate
   
   
 : A!    ( addr1 addr2 -- ) \ gforth  \ : A!    ( addr1 addr2 -- ) \ gforth
     dup relon ! ;  \    dup relon ! ;
 : A,    ( addr -- ) \ gforth  \ : A,    ( addr -- ) \ gforth
     here cell allot A! ;  \    here cell allot A! ;
   ' ! alias A! ( addr1 addr2 -- ) \ gforth
   ' , alias A, ( addr -- ) \ gforth 
   
   
 \ on off                                               23feb93py  \ on off                                               23feb93py
   
Line 140  DOES> ( n -- )  + c@ ; Line 145  DOES> ( n -- )  + c@ ;
 : off ( addr -- ) \ gforth  : off ( addr -- ) \ gforth
     false swap ! ;      false swap ! ;
   
   \ dabs roll                                           17may93jaw
   
   : dabs ( d1 -- d2 ) \ double
       dup 0< IF dnegate THEN ;
   
   : roll  ( x0 x1 .. xn n -- x1 .. xn x0 ) \ core-ext
     dup 1+ pick >r
     cells sp@ cell+ dup cell+ rot move drop r> ;
   
 \ name> found                                          17dec92py  \ name> found                                          17dec92py
   
 : (name>)  ( nfa -- cfa )  $80 constant alias-mask \ set when the word is not an alias!
     count  $1F and  +  cfaligned ;  $40 constant immediate-mask
 : name>    ( nfa -- cfa ) \ gforth  $20 constant restrict-mask
     cell+  
     dup  (name>) swap  c@ $80 and 0= IF  @ THEN ;  : ((name>))  ( nfa -- cfa )
       name>string +  cfaligned ;
 : found ( nfa -- cfa n ) \ gforth  
     cell+  : (name>x) ( nfa -- cfa b )
     dup c@ >r  (name>) r@ $80 and  0= IF  @       THEN      \ cfa is an intermediate cfa and b is the flags byte of nfa
                     -1 r@ $40 and     IF  1-      THEN      dup ((name>))
                        r> $20 and     IF  negate  THEN  ;      swap cell+ c@ dup alias-mask and 0=
       IF
 \ (find)                                               17dec92py          swap @ swap
       THEN ;
 \ : (find) ( addr count nfa1 -- nfa2 / false )  
 \   BEGIN  dup  WHILE  dup >r  
 \          cell+ count $1F and dup >r 2over r> =  
 \          IF  -text  0= IF  2drop r> EXIT  THEN  
 \          ELSE  2drop drop  THEN  r> @  
 \   REPEAT nip nip ;  
   
 \ place bounds                                         13feb93py  \ place bounds                                         13feb93py
   
Line 170  DOES> ( n -- )  + c@ ; Line 178  DOES> ( n -- )  + c@ ;
 : bounds ( beg count -- end beg ) \ gforth  : bounds ( beg count -- end beg ) \ gforth
     over + swap ;      over + swap ;
   
   : save-mem      ( addr1 u -- addr2 u ) \ gforth
       \ copy a memory block into a newly allocated region in the heap
       swap >r
       dup allocate throw
       swap 2dup r> -rot move ;
   
   : extend-mem    ( addr1 u1 u -- addr addr2 u2 )
       \ extend memory block allocated from the heap by u aus
       \ the (possibly reallocated piece is addr2 u2, the extension is at addr
       over >r + dup >r resize throw
       r> over r> + -rot ;
   
 \ input stream primitives                              23feb93py  \ input stream primitives                              23feb93py
   
 : tib ( -- c-addr ) \ core-ext  : tib ( -- c-addr ) \ core-ext
Line 244  Defer source ( -- addr count ) \ core Line 264  Defer source ( -- addr count ) \ core
 \ Literal                                              17dec92py  \ Literal                                              17dec92py
   
 : Literal  ( compilation n -- ; run-time -- n ) \ core  : Literal  ( compilation n -- ; run-time -- n ) \ core
     state @ IF postpone lit  , THEN ; immediate      postpone lit  , ; immediate restrict
 : ALiteral ( compilation addr -- ; run-time -- addr ) \ gforth  : ALiteral ( compilation addr -- ; run-time -- addr ) \ gforth
     state @ IF postpone lit A, THEN ;      postpone lit A, ; immediate restrict
                                                       immediate  
   
 : char   ( 'char' -- n ) \ core  : char   ( 'char' -- n ) \ core
     bl word char+ c@ ;      bl word char+ c@ ;
 : [char] ( compilation 'char' -- ; run-time -- n )  : [char] ( compilation 'char' -- ; run-time -- n )
     char postpone Literal ; immediate      char postpone Literal ; immediate restrict
 ' [char] Alias Ascii immediate  
   
 : (compile) ( -- ) \ gforth  : (compile) ( -- ) \ gforth
     r> dup cell+ >r @ compile, ;      r> dup cell+ >r @ compile, ;
 : postpone ( "name" -- ) \ core  
   name sfind dup 0= abort" Can't compile "  \ not the most efficient implementation of POSTPONE, but simple
   0> IF  compile,  ELSE  postpone (compile) A,  THEN ;  : POSTPONE ( -- ) \ core
                                              immediate restrict      COMP' swap POSTPONE aliteral compile, ; immediate restrict
   
   : interpret/compile: ( interp-xt comp-xt "name" -- )
       Create immediate swap A, A,
   DOES>
       abort" executed primary cfa of an interpret/compile: word" ;
   \    state @ IF  cell+  THEN  perform ;
   
 \ Use (compile) for the old behavior of compile!  \ Use (compile) for the old behavior of compile!
   
Line 450  hex Line 474  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 4 cells ! ]          [ here 9 cells ! ]
         handler @ rp!          handler @ rp!
         r> handler !          r> handler !
         r> lp!          r> lp!
Line 483  Defer parser Line 507  Defer parser
 Defer name ( -- c-addr count ) \ gforth  Defer name ( -- c-addr count ) \ gforth
 \ get the next word from the input buffer  \ get the next word from the input buffer
 ' (name) IS name  ' (name) IS name
 Defer notfound ( c-addr count -- )  Defer compiler-notfound ( c-addr count -- )
   Defer interpreter-notfound ( c-addr count -- )
   
 : no.extensions  ( addr u -- )  : no.extensions  ( addr u -- )
     2drop -&13 bounce ;      2drop -&13 bounce ;
 ' no.extensions IS notfound  ' no.extensions IS compiler-notfound
   ' no.extensions IS interpreter-notfound
   
   : compile-only-error ( ... -- )
       -&14 throw ;
   
 : interpret ( ?? -- ?? ) \ gforth  : interpret ( ?? -- ?? ) \ gforth
     \ interpret/compile the (rest of the) input buffer      \ interpret/compile the (rest of the) input buffer
Line 500  Defer notfound ( c-addr count -- ) Line 529  Defer notfound ( c-addr count -- )
   
 \ interpreter compiler                                 30apr92py  \ interpreter compiler                                 30apr92py
   
 : interpreter  ( c-addr u -- ) \ gforth  \ not the most efficient implementations of interpreter and compiler
     \ interpretation semantics for the name/number c-addr u  : interpreter ( c-addr u -- ) 
     2dup sfind dup      2dup find-name dup
     IF      if
         1 and          nip nip name>int execute
         IF \ not restricted to compile state?      else
             nip nip execute EXIT          drop
         THEN          2dup 2>r snumber?
         -&14 throw  
     THEN  
     drop  
     2dup 2>r snumber?  
     IF  
         2rdrop  
     ELSE  
         2r> notfound  
     THEN ;  
   
 ' interpreter  IS  parser  
   
 : compiler     ( c-addr u -- ) \ gforth  
     \ compilation semantics for the name/number c-addr u  
     2dup sfind dup  
     IF  
         0>  
         IF          IF
             nip nip execute EXIT              2rdrop
           ELSE
               2r> interpreter-notfound
         THEN          THEN
         compile, 2drop EXIT      then ;
     THEN  
     drop  : compiler ( c-addr u -- )
     2dup snumber? dup      2dup find-name dup
     IF      if ( c-addr u nfa )
         0>          nip nip name>comp execute
       else
           drop
           2dup snumber? dup
         IF          IF
             swap postpone Literal              0>
               IF
                   swap postpone Literal
               THEN
               postpone Literal
               2drop
           ELSE
               drop compiler-notfound
         THEN          THEN
         postpone Literal      then ;
         2drop  
     ELSE  ' interpreter  IS  parser
         drop notfound  
     THEN ;  
   
 : [ ( -- ) \ core       left-bracket  : [ ( -- ) \ core       left-bracket
     ['] interpreter  IS parser state off ; immediate      ['] interpreter  IS parser state off ; immediate
Line 581  variable backedge-locals Line 603  variable backedge-locals
     0 backedge-locals ! ; immediate      0 backedge-locals ! ; immediate
   
 : ASSUME-LIVE ( orig -- orig ) \ gforth  : ASSUME-LIVE ( orig -- orig ) \ gforth
     \ used immediateliy before a BEGIN that is not reachable from      \ used immediatly before a BEGIN that is not reachable from
     \ above.  causes the BEGIN to assume that the same locals are live      \ above.  causes the BEGIN to assume that the same locals are live
     \ as at the orig point      \ as at the orig point
     dup orig?      dup orig?
Line 619  variable backedge-locals Line 641  variable backedge-locals
    over 0<>     over 0<>
  while   while
    over     over
    name> >body @ max     ((name>)) >body @ max
    swap @ swap ( get next )     swap @ swap ( get next )
  repeat   repeat
  faligned nip ;   faligned nip ;
Line 720  variable backedge-locals Line 742  variable backedge-locals
   
 : ?DUP-IF ( compilation -- orig ; run-time n -- n| ) \ gforth   question-dupe-if  : ?DUP-IF ( compilation -- orig ; run-time n -- n| ) \ gforth   question-dupe-if
 \ This is the preferred alternative to the idiom "?DUP IF", since it can be  \ This is the preferred alternative to the idiom "?DUP IF", since it can be
 \ better handled by tools like stack checkers  \ better handled by tools like stack checkers. Besides, it's faster.
     POSTPONE ?dup POSTPONE if ;       immediate restrict      POSTPONE ?dup-?branch >mark ;       immediate restrict
   
 : ?DUP-0=-IF ( compilation -- orig ; run-time n -- n| ) \ gforth        question-dupe-zero-equals-if  : ?DUP-0=-IF ( compilation -- orig ; run-time n -- n| ) \ gforth        question-dupe-zero-equals-if
     POSTPONE ?dup POSTPONE 0= POSTPONE if ; immediate restrict      POSTPONE ?dup-0=-?branch >mark ;       immediate restrict
   
 : THEN ( compilation orig -- ; run-time -- ) \ core  : then-like ( orig -- addr )
     dup orig?      swap -rot dead-orig =
     dead-orig =  
     if      if
         >resolve drop          drop
     else      else
         dead-code @          dead-code @
         if          if
             >resolve set-locals-size-list dead-code off              set-locals-size-list dead-code off
         else \ both live          else \ both live
             over list-size adjust-locals-size              dup list-size adjust-locals-size
             >resolve  
             locals-list @ common-list dup list-size adjust-locals-size              locals-list @ common-list dup list-size adjust-locals-size
             locals-list !              locals-list !
         then          then
     then ; immediate restrict      then ;
   
   : THEN ( compilation orig -- ; run-time -- ) \ core
       dup orig?  then-like  >resolve ; immediate restrict
   
 ' THEN alias ENDIF ( compilation orig -- ; run-time -- ) \ gforth  ' THEN alias ENDIF ( compilation orig -- ; run-time -- ) \ gforth
 immediate restrict  immediate restrict
Line 769  immediate restrict Line 793  immediate restrict
 \ issue a warning (see below). The following code is generated:  \ issue a warning (see below). The following code is generated:
 \ lp+!# (current-local-size - dest-locals-size)  \ lp+!# (current-local-size - dest-locals-size)
 \ branch <begin>  \ branch <begin>
 : AGAIN ( compilation dest -- ; run-time -- ) \ core-ext  
     dest?  : again-like ( dest -- addr )
     over list-size adjust-locals-size      over list-size adjust-locals-size
     POSTPONE branch      swap check-begin  POSTPONE unreachable ;
     <resolve  
     check-begin  : AGAIN ( compilation dest -- ; run-time -- ) \ core-ext
     POSTPONE unreachable ; immediate restrict      dest? again-like  POSTPONE branch  <resolve ; immediate restrict
   
 \ UNTIL (the current control flow may join an earlier one or continue):  \ UNTIL (the current control flow may join an earlier one or continue):
 \ Similar to AGAIN. The new locals-list and locals-size are the current  \ Similar to AGAIN. The new locals-list and locals-size are the current
Line 878  Avariable leave-sp  leave-stack 3 cells Line 902  Avariable leave-sp  leave-stack 3 cells
 : ?DO ( compilation -- do-sys ; run-time w1 w2 -- | loop-sys )  \ core-ext      question-do  : ?DO ( compilation -- do-sys ; run-time w1 w2 -- | loop-sys )  \ core-ext      question-do
     POSTPONE (?do) ?do-like ; immediate restrict      POSTPONE (?do) ?do-like ; immediate restrict
   
 : +DO ( compilation -- do-sys ; run-time w1 w2 -- | loop-sys )  \ gforth        plus-do  : +DO ( compilation -- do-sys ; run-time n1 n2 -- | loop-sys )  \ gforth        plus-do
     POSTPONE (+do) ?do-like ; immediate restrict      POSTPONE (+do) ?do-like ; immediate restrict
   
 : U+DO ( compilation -- do-sys ; run-time w1 w2 -- | loop-sys ) \ gforth        u-plus-do  : U+DO ( compilation -- do-sys ; run-time u1 u2 -- | loop-sys ) \ gforth        u-plus-do
     POSTPONE (u+do) ?do-like ; immediate restrict      POSTPONE (u+do) ?do-like ; immediate restrict
   
 : -DO ( compilation -- do-sys ; run-time w1 w2 -- | loop-sys )  \ gforth        minus-do  : -DO ( compilation -- do-sys ; run-time n1 n2 -- | loop-sys )  \ gforth        minus-do
     POSTPONE (-do) ?do-like ; immediate restrict      POSTPONE (-do) ?do-like ; immediate restrict
   
 : U-DO ( compilation -- do-sys ; run-time w1 w2 -- | loop-sys ) \ gforth        u-minus-do  : U-DO ( compilation -- do-sys ; run-time u1 u2 -- | loop-sys ) \ gforth        u-minus-do
     POSTPONE (u-do) ?do-like ; immediate restrict      POSTPONE (u-do) ?do-like ; immediate restrict
   
 : FOR ( compilation -- do-sys ; run-time w -- loop-sys )        \ gforth  : FOR ( compilation -- do-sys ; run-time u -- loop-sys )        \ gforth
     POSTPONE (for)      POSTPONE (for)
     POSTPONE begin drop do-dest      POSTPONE begin drop do-dest
     ( 0 0 0 >leave ) ; immediate restrict      ( 0 0 0 >leave ) ; immediate restrict
Line 936  Avariable leave-sp  leave-stack 3 cells Line 960  Avariable leave-sp  leave-stack 3 cells
 : ," ( "string"<"> -- ) [char] " parse  : ," ( "string"<"> -- ) [char] " parse
   here over char+ allot  place align ;    here over char+ allot  place align ;
 : "lit ( -- addr )  : "lit ( -- addr )
   r> r> dup count + aligned >r swap >r ;               restrict    r> r> dup count + aligned >r swap >r ;
 : (.")     "lit count type ;                           restrict  : (.")     "lit count type ;
 : (S")     "lit count ;                                restrict  : (S")     "lit count ;
 : SLiteral ( Compilation c-addr1 u ; run-time -- c-addr2 u ) \ string  : SLiteral ( Compilation c-addr1 u ; run-time -- c-addr2 u ) \ string
     postpone (S") here over char+ allot  place align ;      postpone (S") here over char+ allot  place align ;
                                              immediate restrict                                               immediate restrict
 create s"-buffer /line chars allot  
 : S" ( compilation 'ccc"' -- ; run-time -- c-addr u )   \ core,file     s-quote  
     [char] " parse  
     state @  
     IF  
         postpone SLiteral  
     ELSE  
         /line min >r s"-buffer r@ cmove  
         s"-buffer r>  
     THEN ; immediate  
   
 : ." ( compilation 'ccc"' -- ; run-time -- )  \ core    dot-quote  
     state @  IF    postpone (.") ,"  align  
                     ELSE  [char] " parse type  THEN  ;  immediate  
 : ( ( compilation 'ccc<close-paren>' -- ; run-time -- ) \ core,file     paren  : ( ( compilation 'ccc<close-paren>' -- ; run-time -- ) \ core,file     paren
     [char] ) parse 2drop ;                       immediate      BEGIN
           >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 983  create s"-buffer /line chars allot Line 999  create s"-buffer /line chars allot
   
 \ Header states                                        23feb93py  \ Header states                                        23feb93py
   
 : flag! ( 8b -- )  : cset ( bmask c-addr -- )
     last @ dup 0= abort" last word was headerless"      tuck c@ or swap c! ; 
     cell+ tuck c@ xor swap c! ;  : creset ( bmask c-addr -- )
 : immediate     $20 flag! ;      tuck c@ swap invert and swap c! ; 
 : restrict      $40 flag! ;  : ctoggle ( bmask c-addr -- )
 \ ' noop alias restrict      tuck c@ xor swap c! ; 
   
   : lastflags ( -- c-addr )
       \ the address of the flags byte in the last header
       \ aborts if the last defined word was headerless
       last @ dup 0= abort" last word was headerless" cell+ ;
   
   : immediate     immediate-mask lastflags cset ;
   : restrict      restrict-mask lastflags cset ;
   
 \ Header                                               23feb93py  \ Header                                               23feb93py
   
Line 1004  defer header ( -- ) \ gforth Line 1028  defer header ( -- ) \ gforth
     \ puts down string as cstring      \ puts down string as cstring
     dup c, here swap chars dup allot move ;      dup c, here swap chars dup allot move ;
   
 : name,  ( "name" -- ) \ gforth  : header, ( c-addr u -- ) \ gforth
     name name-too-short? name-too-long?      name-too-long?
     string, cfalign ;      align here last !
 : input-stream-header ( "name" -- )      current @ 1 or A,   \ link field; before revealing, it contains the
     \ !! this is f83-implementation-dependent                          \ tagged reveal-into wordlist
     align here last !  -1 A,      string, cfalign
     name, $80 flag! ;      alias-mask lastflags cset ;
   
   : input-stream-header ( "name" -- )
       name name-too-short? header, ;
 : input-stream ( -- )  \ general  : input-stream ( -- )  \ general
 \ switches back to getting the name from the input stream ;  \ switches back to getting the name from the input stream ;
     ['] input-stream-header IS (header) ;      ['] input-stream-header IS (header) ;
Line 1022  defer header ( -- ) \ gforth Line 1048  defer header ( -- ) \ gforth
 create nextname-buffer 32 chars allot  create nextname-buffer 32 chars allot
   
 : nextname-header ( -- )  : nextname-header ( -- )
     \ !! f83-implementation-dependent      nextname-buffer count header,
     nextname-buffer count  
     align here last ! -1 A,  
     string, cfalign  
     $80 flag!  
     input-stream ;      input-stream ;
   
 \ the next name is given in the string  \ the next name is given in the string
Line 1049  create nextname-buffer 32 chars allot Line 1071  create nextname-buffer 32 chars allot
     lastcfa @ ;      lastcfa @ ;
   
 : Alias    ( cfa "name" -- ) \ gforth  : Alias    ( cfa "name" -- ) \ gforth
   Header reveal , $80 flag! ;      Header reveal
       alias-mask lastflags creset
       dup A, lastcfa ! ;
   
 : name>string ( nfa -- addr count ) \ gforth    name-to-string  : name>string ( nfa -- addr count ) \ gforth    name-to-string
  cell+ count $1F and ;   cell+ count $1F and ;
Line 1057  create nextname-buffer 32 chars allot Line 1081  create nextname-buffer 32 chars allot
 Create ???  0 , 3 c, char ? c, char ? c, char ? c,  Create ???  0 , 3 c, char ? c, char ? c, char ? c,
 : >name ( cfa -- nfa ) \ gforth to-name  : >name ( cfa -- nfa ) \ gforth to-name
  $21 cell do   $21 cell do
    dup i - count $9F and + cfaligned over $80 + = if     dup i - count $9F and + cfaligned over alias-mask + = if
      i - cell - unloop exit       i - cell - unloop exit
    then     then
  cell +loop   cell +loop
Line 1078  Create ???  0 , 3 c, char ? c, char ? c, Line 1102  Create ???  0 , 3 c, char ? c, char ? c,
 : dodoes,  ( -- )  : dodoes,  ( -- )
   here /does-handler allot does-handler! ;    here /does-handler allot does-handler! ;
   
 : Create ( -- ) \ core  : Create ( "name" -- ) \ core
     Header reveal dovar: cfa, ;      Header reveal dovar: cfa, ;
   
 \ DOES>                                                17mar93py  
   
 : DOES>  ( compilation colon-sys1 -- colon-sys2 ; run-time nest-sys -- ) \ core does  
     state @  
     IF  
         ;-hook postpone (does>) ?struc dodoes,  
     ELSE  
         align dodoes, here !does ]  
     THEN   
     defstart :-hook ; immediate  
   
 \ Create Variable User Constant                        17mar93py  \ Create Variable User Constant                        17mar93py
   
 : Variable ( -- ) \ core  : Variable ( "name" -- ) \ core
     Create 0 , ;      Create 0 , ;
 : AVariable ( -- ) \ gforth  : AVariable ( "name" -- ) \ gforth
     Create 0 A, ;      Create 0 A, ;
 : 2VARIABLE ( "name" -- ) \ double  : 2VARIABLE ( "name" -- ) \ double
     create 0 , 0 , ;      create 0 , 0 , ;
           
 : User  : User ( "name" -- ) \ gforth
     Variable ;      Variable ;
 : AUser  : AUser ( "name" -- ) \ gforth
     AVariable ;      AVariable ;
   
 : (Constant)  Header reveal docon: cfa, ;  : (Constant)  Header reveal docon: cfa, ;
 : Constant ( w -- ) \ core  : Constant ( w "name" -- ) \ core
     (Constant) , ;      (Constant) , ;
 : AConstant ( addr -- ) \ gforth  : AConstant ( addr "name" -- ) \ gforth
     (Constant) A, ;      (Constant) A, ;
   
 : 2Constant ( d -- ) \ double  : 2Constant ( w1 w2 "name" -- ) \ double
     Create ( w1 w2 "name" -- )      Create ( w1 w2 "name" -- )
         2,          2,
     DOES> ( -- w1 w2 )      DOES> ( -- w1 w2 )
Line 1120  Create ???  0 , 3 c, char ? c, char ? c, Line 1133  Create ???  0 , 3 c, char ? c, char ? c,
           
 \ IS Defer What's Defers TO                            24feb93py  \ IS Defer What's Defers TO                            24feb93py
   
 : Defer ( -- ) \ 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 ( -- )   \     Create ( -- ) 
 \       ['] noop A,  \       ['] noop A,
 \     DOES> ( ??? )  \     DOES> ( ??? )
 \       @ execute ;  \       perform ;
   
 : IS ( addr "name" -- ) \ gforth  
     ' >body  
     state @  
     IF    postpone ALiteral postpone !    
     ELSE  !  
     THEN ;  immediate  
 ' IS Alias TO ( addr "name" -- ) \ core-ext  
 immediate  
   
 : What's ( "name" -- addr ) \ gforth  
     ' >body  
     state @  
     IF  
         postpone ALiteral postpone @  
     ELSE  
         @  
     THEN ; immediate  
 : Defers ( "name" -- ) \ gforth  : Defers ( "name" -- ) \ gforth
     ' >body @ compile, ; immediate      ' >body @ compile, ; immediate
   
Line 1154  immediate Line 1150  immediate
 defer :-hook ( sys1 -- sys2 )  defer :-hook ( sys1 -- sys2 )
 defer ;-hook ( sys2 -- sys1 )  defer ;-hook ( sys2 -- sys1 )
   
 : : ( -- colon-sys ) \ core     colon  : : ( "name" -- colon-sys ) \ core      colon
     Header docol: cfa, defstart ] :-hook ;      Header docol: cfa, defstart ] :-hook ;
 : ; ( compilation colon-sys -- ; run-time nest-sys ) \ core     semicolon  : ; ( compilation colon-sys -- ; run-time nest-sys ) \ core     semicolon
     ;-hook ?struc postpone exit reveal postpone [ ; immediate restrict      ;-hook ?struc postpone exit reveal postpone [ ; immediate restrict
Line 1169  AVariable current ( -- addr ) \ gforth Line 1165  AVariable current ( -- addr ) \ gforth
   
 : last?   ( -- false / nfa nfa )  : last?   ( -- false / nfa nfa )
     last @ ?dup ;      last @ ?dup ;
 : (reveal) ( -- )  : (reveal) ( nfa wid -- )
     last?      ( wid>wordlist-id ) dup >r
     IF      @ over ( name>link ) ! 
         dup @ 0<      r> ! ;
         IF  
             current @ @ over ! current @ !  
         ELSE  
             drop  
         THEN  
     THEN ;  
   
 \ object oriented search list                          17mar93py  \ object oriented search list                          17mar93py
   
Line 1186  AVariable current ( -- addr ) \ gforth Line 1176  AVariable current ( -- addr ) \ gforth
   
 struct  struct
   1 cells: field find-method   \ xt: ( c_addr u wid -- name-id )    1 cells: field find-method   \ xt: ( c_addr u wid -- name-id )
   1 cells: field reveal-method \ xt: ( -- ) \ used by dofield:, must be field    1 cells: field reveal-method \ xt: ( nfa wid -- ) \ used by dofield:, must be field
   1 cells: field rehash-method \ xt: ( wid -- )    1 cells: field rehash-method \ xt: ( wid -- )
 \   \ !! what else  \   \ !! what else
 end-struct wordlist-map-struct  end-struct wordlist-map-struct
Line 1198  struct Line 1188  struct
   1 cells: field wordlist-extend \ points to wordlist extensions (eg hash)    1 cells: field wordlist-extend \ points to wordlist extensions (eg hash)
 end-struct wordlist-struct  end-struct wordlist-struct
   
 : f83find      ( addr len wordlist -- nfa / false )  @ (f83find) ;  : f83find      ( addr len wordlist -- nfa / false )
       ( wid>wordlist-id ) @ (f83find) ;
   
 \ Search list table: find reveal  \ Search list table: find reveal
 Create f83search       ' f83find A,  ' (reveal) A,  ' drop A,  Create f83search ( -- wordlist-map )
       ' f83find A,  ' (reveal) A,  ' drop A,
   
 Create forth-wordlist  NIL A, G f83search T A, NIL A, NIL A,  Create forth-wordlist  NIL A, G f83search T A, NIL A, NIL A,
 AVariable lookup       G forth-wordlist lookup T !  AVariable lookup       G forth-wordlist lookup T !
 G forth-wordlist current T !  G forth-wordlist current T !
   
   \ higher level parts of find
   
   ( struct )
   0 >body cell
     1 cells: field interpret/compile-int
     1 cells: field interpret/compile-comp
   end-struct interpret/compile-struct
   
   : interpret/compile? ( xt -- flag )
       >does-code ['] S" >does-code = ;
   
   : (cfa>int) ( cfa -- xt )
       dup interpret/compile?
       if
           interpret/compile-int @
       then ;
   
   : (x>int) ( cfa b -- xt )
       \ get interpretation semantics of name
       restrict-mask and
       if
           drop ['] compile-only-error
       else
           (cfa>int)
       then ;
   
   : name>int ( nfa -- xt ) \ gforth
       (name>x) (x>int) ;
   
   : name?int ( nfa -- xt ) \ gforth
       \ like name>int, but throws an error if compile-only
       (name>x) restrict-mask and
       if
           compile-only-error \ does not return
       then
       (cfa>int) ;
   
   : name>comp ( nfa -- w xt ) \ gforth
       \ get compilation semantics of name
       (name>x) >r dup interpret/compile?
       if
           interpret/compile-comp @
       then
       r> immediate-mask and if
           ['] execute
       else
           ['] compile,
       then ;
   
 : (search-wordlist)  ( addr count wid -- nfa / false )  : (search-wordlist)  ( addr count wid -- nfa / false )
   dup wordlist-map @ find-method @ execute ;      dup wordlist-map @ find-method perform ;
   
   : flag-sign ( f -- 1|-1 )
       \ true becomes 1, false -1
       0= 2* 1+ ;
   
   : (name>intn) ( nfa -- xt +-1 )
       (name>x) tuck (x>int) ( b xt )
       swap immediate-mask and flag-sign ;
   
   : search-wordlist ( addr count wid -- 0 / xt +-1 ) \ search
       \ xt is the interpretation semantics
       (search-wordlist) dup if
           (name>intn)
       then ;
   
   : find-name ( c-addr u -- nfa/0 )
       lookup @ (search-wordlist) ;
   
 : search-wordlist  ( addr count wid -- 0 / xt +-1 ) \ search  : sfind ( c-addr u -- 0 / xt +-1  ) \ gforth-obsolete
     (search-wordlist) dup  IF  found  THEN ;      find-name dup
       if ( nfa )
           state @
           if
               name>comp ['] execute = flag-sign
           else
               (name>intn)
           then
       then ;
   
   : find ( c-addr -- xt +-1 / c-addr 0 ) \ core
       dup count sfind dup
       if
           rot drop
       then ;
   
   : (') ( "name" -- nfa ) \ gforth
       name find-name dup 0=
       IF
           drop -&13 bounce
       THEN  ;
   
   : [(')]  ( compilation "name" -- ; run-time -- nfa ) \ gforth   bracket-paren-tick
       (') postpone ALiteral ; immediate restrict
   
   : '    ( "name" -- xt ) \ core  tick
       (') name?int ;
   : [']  ( compilation "name" -- ; run-time -- xt ) \ core        bracket-tick
       ' postpone ALiteral ; immediate restrict
   
   : COMP'    ( "name" -- w xt ) \ gforth  c-tick
       (') name>comp ;
   : [COMP']  ( compilation "name" -- ; run-time -- w xt ) \ gforth        bracket-comp-tick
       COMP' swap POSTPONE Aliteral POSTPONE ALiteral ; immediate restrict
   
   \ reveal words
   
 Variable warnings ( -- addr ) \ gforth  Variable warnings ( -- addr ) \ gforth
 G -1 warnings T !  G -1 warnings T !
   
 : check-shadow  ( addr count wid -- )  : check-shadow  ( addr count wid -- )
 \ prints a warning if the string is already present in the wordlist  \ prints a warning if the string is already present in the wordlist
 \ !! should be refined so the user can suppress the warnings  
  >r 2dup 2dup r> (search-wordlist) warnings @ and ?dup if   >r 2dup 2dup r> (search-wordlist) warnings @ and ?dup if
    ." redefined " name>string 2dup type     ." redefined " name>string 2dup type
    compare 0<> if     compare 0<> if
Line 1230  G -1 warnings T ! Line 1322  G -1 warnings T !
  then   then
  2drop 2drop ;   2drop 2drop ;
   
 : sfind ( c-addr u -- xt n / 0 ) \ gforth  
     lookup @ search-wordlist ;  
   
 : find   ( addr -- cfa +-1 / string false ) \ core,search  
     \ !! not ANS conformant: returns +-2 for restricted words  
     dup count sfind dup if  
         rot drop  
     then ;  
   
 : reveal ( -- ) \ gforth  : reveal ( -- ) \ gforth
  last? if      last?
    name>string current @ check-shadow      if \ the last word has a header
  then          dup ( name>link ) @ 1 and
  current @ wordlist-map @ reveal-method @ execute ;          if \ it is still hidden
               dup ( name>link ) @ 1 xor           ( nfa wid )
               2dup >r name>string r> check-shadow ( nfa wid )
               dup wordlist-map @ reveal-method perform
           then
       then ;
   
 : rehash  ( wid -- )  : rehash  ( wid -- )
     dup wordlist-map @ rehash-method @ execute ;      dup wordlist-map @ rehash-method perform ;
   
 : '    ( "name" -- addr ) \ core        tick  
     name sfind 0= if -&13 bounce then ;  
 : [']  ( compilation "name" -- ; run-time --addr ) \ core       bracket-tick  
     ' postpone ALiteral ; immediate  
 \ Input                                                13feb93py  \ Input                                                13feb93py
   
 07 constant #bell ( -- c ) \ gforth  07 constant #bell ( -- c ) \ gforth
Line 1264  G -1 warnings T ! Line 1348  G -1 warnings T !
 0A constant #lf ( -- c ) \ gforth  0A constant #lf ( -- c ) \ gforth
   
 : bell  #bell emit ;  : bell  #bell emit ;
   : cr ( -- ) \ core
       \ emit a newline
       #lf ( sic! ) emit ;
   
 \ : backspaces  0 ?DO  #bs emit  LOOP ;  \ : backspaces  0 ?DO  #bs emit  LOOP ;
 : >string  ( span addr pos1 -- span addr pos1 addr2 len )  
   over 3 pick 2 pick chars /string ;  : (ins) ( max span addr pos1 key -- max span addr pos2 )
 : type-rest ( span addr pos1 -- span addr pos1 back )      >r 2dup + r@ swap c! r> emit 1+ rot 1+ -rot ;
   >string tuck type ;  : (bs) ( max span addr pos1 -- max span addr pos2 flag )
 : (del)  ( max span addr pos1 -- max span addr pos2 )      dup IF
   1- >string over 1+ -rot move          #bs emit bl emit #bs emit 1- rot 1- -rot
   rot 1- -rot  #bs emit  type-rest bl emit 1+ backspaces ;      THEN false ;
 : (ins)  ( max span addr pos1 char -- max span addr pos2 )  : (ret)  true space ;
   >r >string over 1+ swap move 2dup chars + r> swap c!  
   rot 1+ -rot type-rest 1- backspaces 1+ ;  
 : ?del ( max span addr pos1 -- max span addr pos2 0 )  
   dup  IF  (del)  THEN  0 ;  
 : (ret)  type-rest drop true space ;  
 : back  dup  IF  1- #bs emit  ELSE  #bell emit  THEN 0 ;  
 : forw 2 pick over <> IF  2dup + c@ emit 1+  ELSE  #bell emit  THEN 0 ;  
 : eof  2 pick 0=  IF  bye  ELSE  (ret)  THEN ;  
   
 Create ctrlkeys  Create ctrlkeys
   ] false false back  false  eof   false forw  false    ] false false false false  false false false false
     ?del  false (ret) false  false (ret) false false      (bs)  false (ret) false  false (ret) false false
     false false false false  false false false false      false false false false  false false false false
     false false false false  false false false false [      false false false false  false false false false [
   
   defer insert-char
   ' (ins) IS insert-char
 defer everychar  defer everychar
 ' noop IS everychar  ' noop IS everychar
   
 : decode ( max span addr pos1 key -- max span addr pos2 flag )  : decode ( max span addr pos1 key -- max span addr pos2 flag )
   everychar    everychar
   dup #del = IF  drop #bs  THEN  \ del is rubout    dup #del = IF  drop #bs  THEN  \ del is rubout
   dup bl <   IF  cells ctrlkeys + @ execute  EXIT  THEN    dup bl <   IF  cells ctrlkeys + perform  EXIT  THEN
   >r 2over = IF  rdrop bell 0 EXIT  THEN    >r 2over = IF  rdrop bell 0 EXIT  THEN
   r> (ins) 0 ;    r> insert-char 0 ;
   
 \ decode should better use a table for control key actions  
 \ to define keyboard bindings later  
   
 : 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 
Line 1311  defer everychar Line 1389  defer everychar
   
 \ Output                                               13feb93py  \ Output                                               13feb93py
   
   : (type) ( c-addr u -- ) \ gforth
       outfile-id write-file drop \ !! use ?DUP-IF THROW ENDIF instead of DROP ?
   ;
   
 Defer type ( c-addr u -- ) \ core  Defer type ( c-addr u -- ) \ core
 \ defer type for a output buffer or fast  \ defer type for a output buffer or fast
 \ screen write  \ screen write
   
 \ : (type) ( addr len -- )  
 \   bounds ?DO  I c@ emit  LOOP ;  
   
 ' (type) IS Type  ' (type) IS Type
   
   : (emit) ( c -- ) \ gforth
       outfile-id emit-file drop \ !! use ?DUP-IF THROW ENDIF instead of DROP ?
   ;
   
 Defer emit ( c -- ) \ core  Defer emit ( c -- ) \ core
 ' (Emit) IS Emit  ' (Emit) IS Emit
   
 Defer key ( -- c ) \ core  Defer key ( -- c ) \ core
 ' (key) IS key  ' (key) IS key
   
 \ : form  ( -- rows cols )  &24 &80 ;  
 \ form should be implemented using TERMCAPS or CURSES  
 \ : rows  form drop ;  
 \ : cols  form nip  ;  
   
 \ Query                                                07apr93py  \ Query                                                07apr93py
   
 : refill ( -- flag ) \ core-ext,block-ext,file-ext  : refill ( -- flag ) \ core-ext,block-ext,file-ext
Line 1338  Defer key ( -- c ) \ core Line 1416  Defer key ( -- c ) \ core
   tib /line    tib /line
   loadfile @ ?dup    loadfile @ ?dup
   IF    read-line throw    IF    read-line throw
   ELSE  loadline @ 0< IF 2drop false EXIT THEN    ELSE  sourceline# 0< IF 2drop false EXIT THEN
         accept true          accept true
   THEN    THEN
   1 loadline +!    1 loadline +!
Line 1355  Defer key ( -- c ) \ core Line 1433  Defer key ( -- c ) \ core
 \ 2 c, here char r c, char + c, 0 c,  \ 2 c, here char r c, char + c, 0 c,
 \ 2 c, here char w c, char + c, 0 c, align  \ 2 c, here char w c, char + c, 0 c, align
 4 Constant w/o ( -- fam ) \ file        w-o  4 Constant w/o ( -- fam ) \ file        w-o
 2 Constant r/w ( -- fam ) \ file        r-o  2 Constant r/w ( -- fam ) \ file        r-w
 0 Constant r/o ( -- fam ) \ file        r-w  0 Constant r/o ( -- fam ) \ file        r-o
   
 \ BIN WRITE-LINE                                        11jun93jaw  \ BIN WRITE-LINE                                        11jun93jaw
   
Line 1380  create nl$ 1 c, A c, 0 c, \ gnu includes Line 1458  create nl$ 1 c, A c, 0 c, \ gnu includes
 \ include-file                                         07apr93py  \ include-file                                         07apr93py
   
 : push-file  ( -- )  r>  : push-file  ( -- )  r>
   loadline @ >r loadfile @ >r    sourceline# >r  loadfile @ >r
   blk @ >r >tib @ >r  #tib @ dup >r  >tib +!  >in @ >r  >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 )  : pop-file   ( throw-code -- throw-code )
   dup IF    dup IF
          source >in @ loadline @ loadfilename 2@           source >in @ sourceline# sourcefilename
          error-stack dup @ dup 1+           error-stack dup @ dup 1+
          max-errors 1- min error-stack !           max-errors 1- min error-stack !
          6 * cells + cell+           6 * cells + cell+
Line 1394  create nl$ 1 c, A c, 0 c, \ gnu includes Line 1474  create nl$ 1 c, A c, 0 c, \ gnu includes
          -1 cells +LOOP           -1 cells +LOOP
   THEN    THEN
   r>    r>
   r> >in !  r> #tib !  r> >tib !  r> blk !    r> >in !  r> #tib !  r> >tib !  r> tibstack !  r> blk !
   r> loadfile ! r> loadline !  >r ;    r> loadfile ! r> loadline !  >r ;
   
 : read-loop ( i*x -- j*x )  : read-loop ( i*x -- j*x )
Line 1421  create pathfilenamebuf 256 chars allot \ Line 1501  create pathfilenamebuf 256 chars allot \
 \   ELSE   false  \   ELSE   false
 \   THEN ;  \   THEN ;
   
   : absolut-path? ( addr u -- flag ) \ gforth
       \ a path is absolute, if it starts with a / or a ~ (~ expansion),
       \ or if it is in the form ./* or ../*, extended regexp: [/~]|./|../
       \ Pathes simply containing a / are not absolute!
       over c@ '/ = >r
       over c@ '~ = >r
       2dup 2 min S" ./" compare 0= >r
            3 min S" ../" compare 0=
       r> r> r> or or or ;
   \   [char] / scan nip 0<> ;    
   
 : open-path-file ( c-addr1 u1 -- file-id c-addr2 u2 ) \ gforth  : open-path-file ( c-addr1 u1 -- file-id c-addr2 u2 ) \ gforth
     \ opens a file for reading, searching in the path for it (unless      \ opens a file for reading, searching in the path for it (unless
     \ the filename contains a slash); c-addr2 u2 is the full filename      \ the filename contains a slash); c-addr2 u2 is the full filename
Line 1430  create pathfilenamebuf 256 chars allot \ Line 1521  create pathfilenamebuf 256 chars allot \
     \ the path will usually contain dirs that are only readable for      \ the path will usually contain dirs that are only readable for
     \ the user      \ the user
     \ !! use file-status to determine access mode?      \ !! use file-status to determine access mode?
     2dup [char] / scan nip ( 0<> )      2dup absolut-path?
     if \ the filename contains a slash      if \ the filename contains a slash
         2dup r/o open-file throw ( c-addr1 u1 file-id )          2dup r/o open-file throw ( c-addr1 u1 file-id )
         -rot >r pathfilenamebuf r@ cmove ( file-id R: u1 )          -rot >r pathfilenamebuf r@ cmove ( file-id R: u1 )
Line 1453  create pathfilenamebuf 256 chars allot \ Line 1544  create pathfilenamebuf 256 chars allot \
     pathfilenamebuf swap ;      pathfilenamebuf swap ;
   
 create included-files 0 , 0 , ( pointer to and count of included files )  create included-files 0 , 0 , ( pointer to and count of included files )
 create image-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  \ included-files points to ALLOCATEd space, while image-included-files
 \ points to ALLOTed objects, so it survives a save-system  \ points to ALLOTed objects, so it survives a save-system
   
Line 1461  create image-included-files 0 , 0 , ( po Line 1553  create image-included-files 0 , 0 , ( po
     \ a-addr 2@ produces the current file name ( c-addr u )      \ a-addr 2@ produces the current file name ( c-addr u )
     included-files 2@ drop loadfilename# @ 2* cells + ;      included-files 2@ drop loadfilename# @ 2* cells + ;
   
   : sourcefilename ( -- c-addr u ) \ gforth
       \ the name of the source file which is currently the input
       \ source.  The result is valid only while the file is being
       \ loaded.  If the current input source is no (stream) file, the
       \ result is undefined.
       loadfilename 2@ ;
   
   : sourceline# ( -- u ) \ gforth         sourceline-number
       \ the line number of the line that is currently being interpreted
       \ from a (stream) file. The first line has the number 1. If the
       \ current input source is no (stream) file, the result is
       \ undefined.
       loadline @ ;
   
 : init-included-files ( -- )  : init-included-files ( -- )
     image-included-files 2@ 2* cells save-string drop ( addr )      image-included-files 2@ 2* cells save-mem drop ( addr )
     image-included-files 2@ nip included-files 2! ;      image-included-files 2@ nip included-files 2! ;
   
 : included? ( c-addr u -- f ) \ gforth  : included? ( c-addr u -- f ) \ gforth
Line 1480  create image-included-files 0 , 0 , ( po Line 1586  create image-included-files 0 , 0 , ( po
   
 : add-included-file ( c-addr u -- ) \ gforth  : add-included-file ( c-addr u -- ) \ gforth
     \ add name c-addr u to included-files      \ add name c-addr u to included-files
     included-files 2@ tuck 1+ 2* cells resize throw      included-files 2@ 2* cells 2 cells extend-mem
     swap 2dup 1+ included-files 2!      2/ cell / included-files 2!
     2* cells + 2! ;      2! ;
   \    included-files 2@ tuck 1+ 2* cells resize throw
 : save-string           ( addr1 u -- addr2 u ) \ gforth  \    swap 2dup 1+ included-files 2!
     \ !! not a string, but a memblock word  \    2* cells + 2! ;
     swap >r  
     dup allocate throw  
     swap 2dup r> -rot move ;  
   
 : included1 ( i*x file-id c-addr u -- j*x ) \ gforth  : included1 ( i*x file-id c-addr u -- j*x ) \ gforth
     \ include the file file-id with the name given by c-addr u      \ include the file file-id with the name given by c-addr u
     loadfilename# @ >r      loadfilename# @ >r
     save-string add-included-file ( file-id )      save-mem add-included-file ( file-id )
     included-files 2@ nip 1- loadfilename# !      included-files 2@ nip 1- loadfilename# !
     ['] include-file catch      ['] include-file catch
     r> loadfilename# !      r> loadfilename# !
Line 1544  create image-included-files 0 , 0 , ( po Line 1647  create image-included-files 0 , 0 , ( po
   
 : recurse ( compilation -- ; run-time ?? -- ?? ) \ core  : recurse ( compilation -- ; run-time ?? -- ?? ) \ core
     lastxt compile, ; immediate restrict      lastxt compile, ; immediate restrict
 : recursive ( -- ) \ gforth  ' reveal alias recursive ( -- ) \ gforth
     reveal last off ; immediate          immediate
   
 \ */MOD */                                              17may93jaw  \ */MOD */                                              17may93jaw
   
Line 1559  create image-included-files 0 , 0 , ( po Line 1662  create image-included-files 0 , 0 , ( po
 \ EVALUATE                                              17may93jaw  \ EVALUATE                                              17may93jaw
   
 : evaluate ( c-addr len -- ) \ core,block  : evaluate ( c-addr len -- ) \ core,block
   push-file  dup #tib ! >tib @ swap move    push-file  #tib ! >tib !
   >in off blk off loadfile off -1 loadline !    >in off blk off loadfile off -1 loadline !
 \  BEGIN  interpret  >in @ #tib @ u>= UNTIL  
   ['] interpret catch    ['] interpret catch
   pop-file throw ;    pop-file throw ;
   
Line 1594  max-errors 6 * cells allot Line 1696  max-errors 6 * cells allot
     \ print value in decimal representation      \ print value in decimal representation
     base @ decimal swap . base ! ;      base @ decimal swap . base ! ;
   
   : hex. ( u -- ) \ gforth
       \ print value as unsigned hex number
       '$ emit base @ swap hex u. base ! ;
   
 : 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
Line 1628  DEFER DOERROR Line 1734  DEFER DOERROR
 ;  ;
   
 : (DoError) ( throw-code -- )  : (DoError) ( throw-code -- )
   loadline @ IF    sourceline# IF
                source >in @ loadline @ 0 0 .error-frame                 source >in @ sourceline# 0 0 .error-frame
   THEN    THEN
   error-stack @ 0 ?DO    error-stack @ 0 ?DO
     -1 error-stack +!      -1 error-stack +!
Line 1659  DEFER DOERROR Line 1765  DEFER DOERROR
         postpone [          postpone [
         ['] 'quit CATCH dup          ['] 'quit CATCH dup
     WHILE      WHILE
         DoError r@ >tib !          DoError r@ >tib ! r@ tibstack !
     REPEAT      REPEAT
     drop r> >tib ! ;      drop r> >tib ! ;
   
 \ Cold                                                 13feb93py  \ Cold                                                 13feb93py
   
 \ : .name ( name -- ) cell+ count $1F and 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 ;
   
Line 1732  Variable argc Line 1838  Variable argc
 Defer 'cold ' noop IS 'cold  Defer 'cold ' noop IS 'cold
   
 : cold ( -- ) \ gforth  : cold ( -- ) \ gforth
       stdout TO outfile-id
     pathstring 2@ process-path pathdirs 2!      pathstring 2@ process-path pathdirs 2!
     init-included-files      init-included-files
     'cold      'cold
Line 1745  Defer 'cold ' noop IS 'cold Line 1852  Defer 'cold ' noop IS 'cold
         cr          cr
     THEN      THEN
     false to script?      false to script?
     ." GForth " version-string type ." , Copyright (C) 1994 Free Software Foundation, Inc." cr      ." GForth " version-string type ." , Copyright (C) 1994-1996 Free Software Foundation, Inc." cr
     ." GForth comes with ABSOLUTELY NO WARRANTY; for details type `license'" cr      ." GForth comes with ABSOLUTELY NO WARRANTY; for details type `license'" cr
     ." Type `bye' to exit"      ." Type `bye' to exit"
     loadline off quit ;      loadline off quit ;
Line 1768  Defer 'cold ' noop IS 'cold Line 1875  Defer 'cold ' noop IS 'cold
   
 : boot ( path **argv argc -- )  : boot ( path **argv argc -- )
   argc ! argv ! cstring>sstring pathstring 2!  main-task up!    argc ! argv ! cstring>sstring pathstring 2!  main-task up!
   sp@ dup s0 ! $10 + >tib ! #tib off >in off    sp@ dup s0 ! $10 + dup >tib ! tibstack ! #tib off >in off
   rp@ r0 !  fp@ f0 !  cold ;    rp@ r0 !  fp@ f0 !  ['] cold catch DoError bye ;
   
 : bye ( -- ) \ tools-ext  : bye ( -- ) \ tools-ext
     script? 0= IF  cr  THEN  0 (bye) ;      script? 0= IF  cr  THEN  0 (bye) ;
Line 1779  Defer 'cold ' noop IS 'cold Line 1886  Defer 'cold ' noop IS 'cold
 \ or space and stackspace overrides  \ or space and stackspace overrides
   
 \ 0 arg contains, however, the name of the program.  \ 0 arg contains, however, the name of the program.
   
   
Removed from v.1.46  
changed lines
  Added in v.1.63

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