Diff for /gforth/Attic/kernal.fs between versions 1.43 and 1.57

version 1.43, 1995/10/16 18:33:11 version 1.57, 1996/05/07 16:15:22
Line 1 Line 1
 \ KERNAL.FS    GForth 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 59  HEX Line 76  HEX
   
 \ 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 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 111  DOES> ( n -- )  + c@ ; Line 128  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 125  DOES> ( n -- )  + c@ ; Line 145  DOES> ( n -- )  + c@ ;
   
 \ name> found                                          17dec92py  \ name> found                                          17dec92py
   
 : (name>)  ( nfa -- cfa )  : (name>)  ( nfa+cell -- cfa )
     count  $1F and  +  cfaligned ;      1 cells - name>string +  cfaligned ;
 : name>    ( nfa -- cfa ) \ gforth  : name>    ( nfa -- cfa ) \ gforth
     cell+      cell+
     dup  (name>) swap  c@ $80 and 0= IF  @ THEN ;      dup  (name>) swap  c@ $80 and 0= IF  @ THEN ;
Line 141  DOES> ( n -- )  + c@ ; Line 161  DOES> ( n -- )  + c@ ;
   
 \ : (find) ( addr count nfa1 -- nfa2 / false )  \ : (find) ( addr count nfa1 -- nfa2 / false )
 \   BEGIN  dup  WHILE  dup >r  \   BEGIN  dup  WHILE  dup >r
 \          cell+ count $1F and dup >r 2over r> =  \          name>string dup >r 2over r> =
 \          IF  -text  0= IF  2drop r> EXIT  THEN  \          IF  -text  0= IF  2drop r> EXIT  THEN
 \          ELSE  2drop drop  THEN  r> @  \          ELSE  2drop drop  THEN  r> @
 \   REPEAT nip nip ;  \   REPEAT nip nip ;
Line 433  hex Line 453  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 472  Defer notfound ( c-addr count -- ) Line 492  Defer notfound ( c-addr count -- )
     2drop -&13 bounce ;      2drop -&13 bounce ;
 ' no.extensions IS notfound  ' no.extensions IS notfound
   
   : compile-only ( ... -- )
       -&14 throw ;
   Defer interpret-special ( c-addr u xt -- ) \ !! use nfa instead of xt?
   ' compile-only IS interpret-special
   
 : interpret ( ?? -- ?? ) \ gforth  : interpret ( ?? -- ?? ) \ gforth
     \ interpret/compile the (rest of the) input buffer      \ interpret/compile the (rest of the) input buffer
     BEGIN      BEGIN
Line 491  Defer notfound ( c-addr count -- ) Line 516  Defer notfound ( c-addr count -- )
         IF \ not restricted to compile state?          IF \ not restricted to compile state?
             nip nip execute EXIT              nip nip execute EXIT
         THEN          THEN
         -&14 throw          interpret-special exit
     THEN      THEN
     drop      drop
     2dup 2>r snumber?      2dup 2>r snumber?
Line 703  variable backedge-locals Line 728  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 ( compilation orig -- ; run-time -- ) \ core
     dup orig?      dup orig?
Line 861  Avariable leave-sp  leave-stack 3 cells Line 887  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 940  create s"-buffer /line chars allot Line 966  create s"-buffer /line chars allot
     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      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 1110  Create ???  0 , 3 c, char ? c, char ? c, Line 1142  Create ???  0 , 3 c, char ? c, char ? c,
 \     Create ( -- )   \     Create ( -- ) 
 \       ['] noop A,  \       ['] noop A,
 \     DOES> ( ??? )  \     DOES> ( ??? )
 \       @ execute ;  \       perform ;
   
 : IS ( addr "name" -- ) \ gforth  : IS ( addr "name" -- ) \ gforth
     ' >body      ' >body
Line 1191  AVariable lookup       G forth-wordlist Line 1223  AVariable lookup       G forth-wordlist
 G forth-wordlist current T !  G forth-wordlist current T !
   
 : (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 ;
   
 : search-wordlist  ( addr count wid -- 0 / xt +-1 ) \ search  : search-wordlist  ( addr count wid -- 0 / xt +-1 ) \ search
     (search-wordlist) dup  IF  found  THEN ;      (search-wordlist) dup  IF  found  THEN ;
Line 1226  G -1 warnings T ! Line 1258  G -1 warnings T !
  last? if   last? if
    name>string current @ check-shadow     name>string current @ check-shadow
  then   then
  current @ wordlist-map @ reveal-method @ execute ;   current @ wordlist-map @ reveal-method perform ;
   
 : rehash  ( wid -- )  : rehash  ( wid -- )
     dup wordlist-map @ rehash-method @ execute ;      dup wordlist-map @ rehash-method perform ;
   
 : '    ( "name" -- addr ) \ core        tick  : '    ( "name" -- addr ) \ core        tick
     name sfind 0= if -&13 bounce then ;      name sfind 0= if -&13 bounce then ;
Line 1247  G -1 warnings T ! Line 1279  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 ;
   
   Variable ^d-mode  -1 ^d-mode ! \ ^d is "EOF" if at beginning of the line
   
 : >string  ( span addr pos1 -- span addr pos1 addr2 len )  : >string  ( span addr pos1 -- span addr pos1 addr2 len )
   over 3 pick 2 pick chars /string ;    over 3 pick 2 pick chars /string ;
 : type-rest ( span addr pos1 -- span addr pos1 back )  : type-rest ( span addr pos1 -- span addr pos1 back )
Line 1264  G -1 warnings T ! Line 1302  G -1 warnings T !
 : (ret)  type-rest drop true space ;  : (ret)  type-rest drop true space ;
 : back  dup  IF  1- #bs emit  ELSE  #bell emit  THEN 0 ;  : 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 ;  : forw 2 pick over <> IF  2dup + c@ emit 1+  ELSE  #bell emit  THEN 0 ;
 : eof  2 pick 0=  IF  bye  ELSE  (ret)  THEN ;  : eof  ^d-mode @  IF
           bye
       ELSE  2 pick over <>
           IF  forw drop (del)  ELSE  #bell emit  THEN  0
       THEN ;
   
 Create ctrlkeys  Create ctrlkeys
   ] false false back  false  eof   false forw  false    ] false false back  false  eof   false forw  false
Line 1278  defer everychar Line 1320  defer 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> (ins) 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 
 \ 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 dup ^d-mode !  UNTIL
   2drop nip ;    2drop nip ;
   
 \ 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 1321  Defer key ( -- c ) \ core Line 1360  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 1338  Defer key ( -- c ) \ core Line 1377  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 1363  create nl$ 1 c, A c, 0 c, \ gnu includes Line 1402  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 1418  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 1477  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 1531  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 ) \ file  : included ( i*x addr u -- j*x ) \ file
     open-path-file included1 ;      open-path-file included1 ;
Line 1536  create image-included-files 0 , 0 , ( po Line 1598  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 1666  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 1697  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 1661  Variable argc Line 1722  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 1709  Variable argc Line 1770  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 1722  Defer 'cold ' noop IS 'cold Line 1784  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 1745  Defer 'cold ' noop IS 'cold Line 1807  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.43  
changed lines
  Added in v.1.57


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