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

Diff for /gforth/Attic/kernal.fs between versions 1.42 and 1.49

version 1.42, 1995/10/11 19:39:34 version 1.49, 1995/11/30 18:01:48
Line 1 Line 1
 \ KERNAL.FS    GNU FORTH kernal                        17dec92py  \ KERNAL.FS    GForth kernal                        17dec92py
 \ $ID:  
   \ Copyright (C) 1995 Free Software Foundation, Inc.
   
   \ This file is part of Gforth.
   
   \ Gforth is free software; you can redistribute it and/or
   \ modify it under the terms of the GNU General Public License
   \ as published by the Free Software Foundation; either version 2
   \ of the License, or (at your option) any later version.
   
   \ This program is distributed in the hope that it will be useful,
   \ but WITHOUT ANY WARRANTY; without even the implied warranty of
   \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
   \ GNU General Public License for more details.
   
   \ You should have received a copy of the GNU General Public License
   \ along with this program; if not, write to the Free Software
   \ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
   
 \ Idea and implementation: Bernd Paysan (py)  \ Idea and implementation: Bernd Paysan (py)
 \ Copyright 1992 by the ANSI figForth Development Group  
   
 \ Log:  ', '- usw. durch [char] ... ersetzt  \ Log:  ', '- usw. durch [char] ... ersetzt
 \       man sollte die unterschiedlichen zahlensysteme  \       man sollte die unterschiedlichen zahlensysteme
Line 84  DOES> ( n -- )  + c@ ; Line 101  DOES> ( n -- )  + c@ ;
 : 2,    ( w1 w2 -- ) \ gforth  : 2,    ( w1 w2 -- ) \ gforth
     here 2 cells allot 2! ;      here 2 cells allot 2! ;
   
 : aligned ( addr -- addr' ) \ core  \ : aligned ( addr -- addr' ) \ core
   [ cell 1- ] Literal + [ -1 cells ] Literal and ;  \     [ cell 1- ] Literal + [ -1 cells ] Literal and ;
 : align ( -- ) \ core  : align ( -- ) \ core
     here dup aligned swap ?DO  bl c,  LOOP ;      here dup aligned swap ?DO  bl c,  LOOP ;
   
 : faligned ( addr -- f-addr ) \ float  \ : faligned ( addr -- f-addr ) \ float
     [ 1 floats 1- ] Literal + [ -1 floats ] Literal and ;  \     [ 1 floats 1- ] Literal + [ -1 floats ] Literal and ;
   
 : falign ( -- ) \ float  : falign ( -- ) \ float
     here dup faligned swap      here dup faligned swap
Line 226  Defer source ( -- addr count ) \ core Line 243  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      state @ IF postpone lit  , THEN ; immediate
 : ALiteral ( compilation: addr -- ; run-time: -- addr ) \ gforth  : ALiteral ( compilation addr -- ; run-time -- addr ) \ gforth
     state @ IF postpone lit A, THEN ;      state @ IF postpone lit A, THEN ;
                                                       immediate                                                        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
 ' [char] Alias Ascii immediate  ' [char] Alias Ascii immediate
   
Line 360  hex Line 377  hex
     >r 0 r@ um/mod r> swap >r      >r 0 r@ um/mod r> swap >r
     um/mod r> ;      um/mod r> ;
   
 : pad    ( -- addr ) \ core  : pad    ( -- addr ) \ core-ext
   here [ $20 8 2* cells + 2 + cell+ ] Literal + aligned ;    here [ $20 8 2* cells + 2 + cell+ ] Literal + aligned ;
   
 \ hold <# #> sign # #s                                 25jan92py  \ hold <# #> sign # #s                                 25jan92py
Line 572  variable backedge-locals Line 589  variable backedge-locals
           
 \ locals list operations  \ locals list operations
   
 : common-list ( list1 list2 -- list3 )  : common-list ( list1 list2 -- list3 ) \ gforth-internal
 \ list1 and list2 are lists, where the heads are at higher addresses than  \ list1 and list2 are lists, where the heads are at higher addresses than
 \ the tail. list3 is the largest sublist of both lists.  \ the tail. list3 is the largest sublist of both lists.
  begin   begin
Line 586  variable backedge-locals Line 603  variable backedge-locals
  repeat   repeat
  drop ;   drop ;
   
 : sub-list? ( list1 list2 -- f )  : sub-list? ( list1 list2 -- f ) \ gforth-internal
 \ true iff list1 is a sublist of list2  \ true iff list1 is a sublist of list2
  begin   begin
    2dup u<     2dup u<
Line 595  variable backedge-locals Line 612  variable backedge-locals
  repeat   repeat
  = ;   = ;
   
 : list-size ( list -- u )  : list-size ( list -- u ) \ gforth-internal
 \ size of the locals frame represented by list  \ size of the locals frame represented by list
  0 ( list n )   0 ( list n )
  begin   begin
Line 695  variable backedge-locals Line 712  variable backedge-locals
   
 \ Structural Conditionals                              12dec92py  \ Structural Conditionals                              12dec92py
   
 : AHEAD ( compilation: -- orig ; run-time: -- ) \ tools-ext  : AHEAD ( compilation -- orig ; run-time -- ) \ tools-ext
     POSTPONE branch  >mark  POSTPONE unreachable ; immediate restrict      POSTPONE branch  >mark  POSTPONE unreachable ; immediate restrict
   
 : IF ( compilation: -- orig ; run-time: f -- ) \ core  : IF ( compilation -- orig ; run-time f -- ) \ core
  POSTPONE ?branch >mark ; immediate restrict   POSTPONE ?branch >mark ; immediate restrict
   
 : ?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
     POSTPONE ?dup POSTPONE if ;       immediate restrict      POSTPONE ?dup POSTPONE if ;       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 POSTPONE 0= POSTPONE if ; immediate restrict
   
 : THEN ( compilation: orig -- ; run-time: -- ) \ core  : THEN ( compilation orig -- ; run-time -- ) \ core
     dup orig?      dup orig?
     dead-orig =      dead-orig =
     if      if
Line 725  variable backedge-locals Line 742  variable backedge-locals
         then          then
     then ; immediate restrict      then ; immediate restrict
   
 ' THEN alias ENDIF ( compilation: orig -- ; run-time: -- ) \ gforth  ' THEN alias ENDIF ( compilation orig -- ; run-time -- ) \ gforth
 immediate restrict  immediate restrict
 \ Same as "THEN". This is what you use if your program will be seen by  \ 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  \ people who have not been brought up with Forth (or who have been
 \ brought up with fig-Forth).  \ brought up with fig-Forth).
   
 : ELSE ( compilation: orig1 -- orig2 ; run-time: f -- ) \ core  : ELSE ( compilation orig1 -- orig2 ; run-time f -- ) \ core
     POSTPONE ahead      POSTPONE ahead
     1 cs-roll      1 cs-roll
     POSTPONE then ; immediate restrict      POSTPONE then ; immediate restrict
   
   
 : BEGIN ( compilation: -- dest ; run-time: -- ) \ core  : BEGIN ( compilation -- dest ; run-time -- ) \ core
     dead-code @ if      dead-code @ if
         \ set up an assumption of the locals visible here.  if the          \ set up an assumption of the locals visible here.  if the
         \ users want something to be visible, they have to declare          \ users want something to be visible, they have to declare
Line 752  immediate restrict Line 769  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  : AGAIN ( compilation dest -- ; run-time -- ) \ core-ext
     dest?      dest?
     over list-size adjust-locals-size      over list-size adjust-locals-size
     POSTPONE branch      POSTPONE branch
Line 778  immediate restrict Line 795  immediate restrict
     then ( list )      then ( list )
     check-begin ;      check-begin ;
   
 : UNTIL ( compilation: dest -- ; run-time: f -- ) \ core  : UNTIL ( compilation dest -- ; run-time f -- ) \ core
     dest? ['] ?branch ['] ?branch-lp+!# until-like ; immediate restrict      dest? ['] ?branch ['] ?branch-lp+!# until-like ; immediate restrict
   
 : WHILE ( compilation: dest -- orig dest ; run-time: f -- ) \ core  : WHILE ( compilation dest -- orig dest ; run-time f -- ) \ core
     POSTPONE if      POSTPONE if
     1 cs-roll ; immediate restrict      1 cs-roll ; immediate restrict
   
 : REPEAT ( compilation: orig dest -- ; run-time: -- ) \ core  : REPEAT ( compilation orig dest -- ; run-time -- ) \ core
     POSTPONE again      POSTPONE again
     POSTPONE then ; immediate restrict      POSTPONE then ; immediate restrict
   
Line 829  Avariable leave-sp  leave-stack 3 cells Line 846  Avariable leave-sp  leave-stack 3 cells
     cell - dup @ swap      cell - dup @ swap
     leave-sp ! ;      leave-sp ! ;
   
 : DONE ( compilation: orig -- ; run-time: -- ) \ gforth  : DONE ( compilation orig -- ; run-time -- ) \ gforth
     \ !! the original done had ( addr -- )      \ !! the original done had ( addr -- )
     drop >r drop      drop >r drop
     begin      begin
Line 840  Avariable leave-sp  leave-stack 3 cells Line 857  Avariable leave-sp  leave-stack 3 cells
     repeat      repeat
     >leave rdrop ; immediate restrict      >leave rdrop ; immediate restrict
   
 : LEAVE ( compilation: -- ; run-time: loop-sys -- ) \ core  : LEAVE ( compilation -- ; run-time loop-sys -- ) \ core
     POSTPONE ahead      POSTPONE ahead
     >leave ; immediate restrict      >leave ; immediate restrict
   
 : ?LEAVE ( compilation: -- ; run-time: f | f loop-sys -- ) \ gforth     question-leave  : ?LEAVE ( compilation -- ; run-time f | f loop-sys -- ) \ gforth       question-leave
     POSTPONE 0= POSTPONE if      POSTPONE 0= POSTPONE if
     >leave ; immediate restrict      >leave ; immediate restrict
   
 : DO ( compilation: -- do-sys ; run-time: w1 w2 -- loop-sys )  : DO ( compilation -- do-sys ; run-time w1 w2 -- loop-sys ) \ core
     POSTPONE (do)      POSTPONE (do)
     POSTPONE begin drop do-dest      POSTPONE begin drop do-dest
     ( 0 0 0 >leave ) ; immediate restrict      ( 0 0 0 >leave ) ; immediate restrict
Line 858  Avariable leave-sp  leave-stack 3 cells Line 875  Avariable leave-sp  leave-stack 3 cells
     >mark >leave      >mark >leave
     POSTPONE begin drop do-dest ;      POSTPONE begin drop do-dest ;
   
 : ?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 w1 w2 -- | 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 w1 w2 -- | 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 w1 w2 -- | 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 w1 w2 -- | 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 w -- 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 884  Avariable leave-sp  leave-stack 3 cells Line 901  Avariable leave-sp  leave-stack 3 cells
     >r >r 0 cs-pick swap cell - swap 1 cs-roll r> r> rot do-dest?      >r >r 0 cs-pick swap cell - swap 1 cs-roll r> r> rot do-dest?
     until-like  POSTPONE done  POSTPONE unloop ;      until-like  POSTPONE done  POSTPONE unloop ;
   
 : LOOP ( compilation: do-sys -- ; run-time: loop-sys1 -- | loop-sys2 )  \ core  : LOOP ( compilation do-sys -- ; run-time loop-sys1 -- | loop-sys2 )    \ core
  ['] (loop) ['] (loop)-lp+!# loop-like ; immediate restrict   ['] (loop) ['] (loop)-lp+!# loop-like ; immediate restrict
   
 : +LOOP ( compilation: do-sys -- ; run-time: loop-sys1 n -- | loop-sys2 )       \ core  plus-loop  : +LOOP ( compilation do-sys -- ; run-time loop-sys1 n -- | loop-sys2 ) \ core  plus-loop
  ['] (+loop) ['] (+loop)-lp+!# loop-like ; immediate restrict   ['] (+loop) ['] (+loop)-lp+!# loop-like ; immediate restrict
   
 \ !! should the compiler warn about +DO..-LOOP?  \ !! should the compiler warn about +DO..-LOOP?
 : -LOOP ( compilation: do-sys -- ; run-time: loop-sys1 u -- | loop-sys2 )       \ gforth        minus-loop  : -LOOP ( compilation do-sys -- ; run-time loop-sys1 u -- | loop-sys2 ) \ gforth        minus-loop
  ['] (-loop) ['] (-loop)-lp+!# loop-like ; immediate restrict   ['] (-loop) ['] (-loop)-lp+!# loop-like ; immediate restrict
   
 \ A symmetric version of "+LOOP". I.e., "-high -low ?DO -inc S+LOOP"  \ 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  \ 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  \ increments it behaves like "+LOOP". Use S+LOOP instead of +LOOP for
 \ negative increments.  \ negative increments.
 : S+LOOP ( compilation: do-sys -- ; run-time: loop-sys1 n -- | loop-sys2 )      \ gforth        s-plus-loop  : 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   ['] (s+loop) ['] (s+loop)-lp+!# loop-like ; immediate restrict
   
 : NEXT ( compilation: do-sys -- ; run-time: loop-sys1 -- | loop-sys2 ) \ gforth  : NEXT ( compilation do-sys -- ; run-time loop-sys1 -- | loop-sys2 ) \ gforth
  ['] (next) ['] (next)-lp+!# loop-like ; immediate restrict   ['] (next) ['] (next)-lp+!# loop-like ; immediate restrict
   
 \ Structural Conditionals                              12dec92py  \ Structural Conditionals                              12dec92py
   
 : EXIT ( compilation: -- ; run-time: nest-sys -- ) \ core  : EXIT ( compilation -- ; run-time nest-sys -- ) \ core
     0 adjust-locals-size      0 adjust-locals-size
     POSTPONE ;s      POSTPONE ;s
     POSTPONE unreachable ; immediate restrict      POSTPONE unreachable ; immediate restrict
   
 : ?EXIT ( -- ) ( compilation: -- ; run-time: nest-sys f -- | nest-sys ) \ gforth  : ?EXIT ( -- ) ( compilation -- ; run-time nest-sys f -- | nest-sys ) \ gforth
      POSTPONE if POSTPONE exit POSTPONE then ; immediate restrict       POSTPONE if POSTPONE exit POSTPONE then ; immediate restrict
   
 \ Strings                                              22feb93py  \ Strings                                              22feb93py
Line 922  Avariable leave-sp  leave-stack 3 cells Line 939  Avariable leave-sp  leave-stack 3 cells
   r> r> dup count + aligned >r swap >r ;               restrict    r> r> dup count + aligned >r swap >r ;               restrict
 : (.")     "lit count type ;                           restrict  : (.")     "lit count type ;                           restrict
 : (S")     "lit count ;                                restrict  : (S")     "lit count ;                                restrict
 : 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  create s"-buffer /line chars allot
 : S" ( compilation: 'ccc"' -- ; run-time: -- c-addr u ) \ core,file     s-quote  : S" ( compilation 'ccc"' -- ; run-time -- c-addr u )   \ core,file     s-quote
     [char] " parse      [char] " parse
     state @      state @
     IF      IF
Line 936  create s"-buffer /line chars allot Line 953  create s"-buffer /line chars allot
         s"-buffer r>          s"-buffer r>
     THEN ; immediate      THEN ; immediate
   
 : ." ( compilation: 'ccc"' -- ; run-time: -- )  \ core  dot-quote  : ." ( compilation 'ccc"' -- ; run-time -- )  \ core    dot-quote
     state @  IF    postpone (.") ,"  align      state @  IF    postpone (.") ,"  align
                     ELSE  [char] " parse type  THEN  ;  immediate                      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      [char] ) parse 2drop ;                       immediate
 : \ ( -- ) \ core-ext backslash  : \ ( -- ) \ core-ext backslash
     blk @      blk @
Line 961  create s"-buffer /line chars allot Line 978  create s"-buffer /line chars allot
         r> "error ! -2 throw          r> "error ! -2 throw
     THEN      THEN
     rdrop ;      rdrop ;
 : abort" ( compilation: 'ccc"' -- ; run-time: f -- ) \ core,exception-ext       abort-quote  : abort" ( compilation 'ccc"' -- ; run-time f -- ) \ core,exception-ext abort-quote
     postpone (abort") ," ;        immediate restrict      postpone (abort") ," ;        immediate restrict
   
 \ Header states                                        23feb93py  \ Header states                                        23feb93py
Line 1066  Create ???  0 , 3 c, char ? c, char ? c, Line 1083  Create ???  0 , 3 c, char ? c, char ? c,
   
 \ DOES>                                                17mar93py  \ DOES>                                                17mar93py
   
 : DOES>  ( compilation: colon-sys1 -- colon-sys2 ; run-time: nest-sys -- ) \ core       does  : DOES>  ( compilation colon-sys1 -- colon-sys2 ; run-time nest-sys -- ) \ core does
     state @      state @
     IF      IF
         ;-hook postpone (does>) ?struc dodoes,          ;-hook postpone (does>) ?struc dodoes,
Line 1139  defer ;-hook ( sys2 -- sys1 ) Line 1156  defer ;-hook ( sys2 -- sys1 )
   
 : : ( -- colon-sys ) \ core     colon  : : ( -- 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
   
 : :noname ( -- xt colon-sys ) \ core-ext        colon-no-name  : :noname ( -- xt colon-sys ) \ core-ext        colon-no-name
Line 1233  G -1 warnings T ! Line 1250  G -1 warnings T !
   
 : '    ( "name" -- addr ) \ core        tick  : '    ( "name" -- addr ) \ core        tick
     name sfind 0= if -&13 bounce then ;      name sfind 0= if -&13 bounce then ;
 : [']  ( compilation: "name" -- ; run-time: --addr ) \ core     bracket-tick  : [']  ( compilation "name" -- ; run-time --addr ) \ core       bracket-tick
     ' postpone ALiteral ; immediate      ' postpone ALiteral ; immediate
 \ Input                                                13feb93py  \ Input                                                13feb93py
   
Line 1321  Defer key ( -- c ) \ core Line 1338  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 1363  create nl$ 1 c, A c, 0 c, \ gnu includes Line 1380  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 1377  create nl$ 1 c, A c, 0 c, \ gnu includes Line 1396  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 1436  create pathfilenamebuf 256 chars allot \ Line 1455  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
   
   : loadfilename ( -- a-addr )
       \ a-addr 2@ produces the current file name ( c-addr u )
       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-string drop ( addr )
     image-included-files 2@ nip included-files 2! ;      image-included-files 2@ nip included-files 2! ;
Line 1471  create image-included-files 0 , 0 , ( po Line 1509  create image-included-files 0 , 0 , ( po
   
 : 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 2@ >r >r      loadfilename# @ >r
     save-string 2dup loadfilename 2! add-included-file ( file-id )      save-string add-included-file ( file-id )
       included-files 2@ nip 1- loadfilename# !
     ['] include-file catch      ['] include-file catch
     r> r> loadfilename 2!  throw ;      r> loadfilename# !
       throw ;
           
 : included ( i*x addr u -- j*x ) \ gforth  : included ( i*x addr u -- j*x ) \ file
     open-path-file included1 ;      open-path-file included1 ;
   
 : required ( i*x addr u -- j*x ) \ gforth  : required ( i*x addr u -- j*x ) \ gforth
Line 1519  create image-included-files 0 , 0 , ( po Line 1559  create image-included-files 0 , 0 , ( po
   
 \ RECURSE                                               17may93jaw  \ RECURSE                                               17may93jaw
   
 : recurse ( compilation: -- ; run-time: ?? -- ?? ) \ core  : recurse ( compilation -- ; run-time ?? -- ?? ) \ core
     lastxt compile, ; immediate restrict      lastxt compile, ; immediate restrict
 : recursive ( -- ) \ gforth  : recursive ( -- ) \ gforth
     reveal last off ; immediate      reveal last off ; immediate
Line 1536  create image-included-files 0 , 0 , ( po Line 1576  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 1605  DEFER DOERROR Line 1644  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 1636  DEFER DOERROR Line 1675  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 ! ;
   
Line 1661  Variable argc Line 1700  Variable argc
   
 : process-path ( addr1 u1 -- addr2 u2 )  : process-path ( addr1 u1 -- addr2 u2 )
     \ addr1 u1 is a path string, addr2 u2 is an array of dir strings      \ addr1 u1 is a path string, addr2 u2 is an array of dir strings
     here >r      align here >r
     BEGIN      BEGIN
         over >r [char] : scan          over >r [char] : scan
         over r> tuck - ( rest-str this-str )          over r> tuck - ( rest-str this-str )
Line 1722  Defer 'cold ' noop IS 'cold Line 1761  Defer 'cold ' noop IS 'cold
         cr          cr
     THEN      THEN
     false to script?      false to script?
     ." GNU Forth " version-string type ." , Copyright (C) 1994 Free Software Foundation, Inc." cr      ." GForth " version-string type ." , Copyright (C) 1994 Free Software Foundation, Inc." cr
     ." GNU Forth 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 1745  Defer 'cold ' noop IS 'cold Line 1784  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) ;
Removed from v.1.42  
changed lines
  Added in v.1.49

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