[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.49

version 1.46, 1995/11/07 18:06:47 version 1.49, 1995/11/30 18:01:48
Line 1338  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 1380  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 1394  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 1453  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
   
Line 1461  create image-included-files 0 , 0 , ( po Line 1464  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-string drop ( addr )
     image-included-files 2@ nip included-files 2! ;      image-included-files 2@ nip included-files 2! ;
Line 1559  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 1628  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 1659  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 1768  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.46  
changed lines
  Added in v.1.49

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