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

Diff for /gforth/kernel/int.fs between versions 1.20 and 1.195

version 1.20, 1999/02/20 22:13:23 version 1.195, 2012/12/31 15:25:19
Line 1 Line 1
 \ definitions needed for interpreter only  \ definitions needed for interpreter only
   
 \ Copyright (C) 1995,1996,1997,1998 Free Software Foundation, Inc.  \ Copyright (C) 1995-2000,2004,2005,2007,2009,2010,2012 Free Software Foundation, Inc.
   
 \ This file is part of Gforth.  \ This file is part of Gforth.
   
 \ Gforth is free software; you can redistribute it and/or  \ Gforth is free software; you can redistribute it and/or
 \ modify it under the terms of the GNU General Public License  \ modify it under the terms of the GNU General Public License
 \ as published by the Free Software Foundation; either version 2  \ as published by the Free Software Foundation, either version 3
 \ of the License, or (at your option) any later version.  \ of the License, or (at your option) any later version.
   
 \ This program is distributed in the hope that it will be useful,  \ This program is distributed in the hope that it will be useful,
Line 15 Line 15
 \ GNU General Public License for more details.  \ GNU General Public License for more details.
   
 \ You should have received a copy of the GNU General Public License  \ You should have received a copy of the GNU General Public License
 \ along with this program; if not, write to the Free Software  \ along with this program. If not, see http://www.gnu.org/licenses/.
 \ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.  
   
 \ \ Revision-Log  \ \ Revision-Log
   
Line 24 Line 23
   
 \ \ input stream primitives                             23feb93py  \ \ input stream primitives                             23feb93py
   
 : tib ( -- c-addr ) \ core-ext  require ./basics.fs     \ bounds decimal hex ...
     \ obsolescent  require ./io.fs         \ type ...
   require ./nio.fs        \ . <# ...
   require ./errore.fs     \ .error ...
   require kernel/version.fs \ version-string
   
   has? new-input 0= [IF]
   : tib ( -- c-addr ) \ core-ext t-i-b
       \G @i{c-addr} is the address of the Terminal Input Buffer.
       \G OBSOLESCENT: @code{source} superceeds the function of this word.
     >tib @ ;      >tib @ ;
   
 Defer source ( -- addr count ) \ core  Defer source ( -- c-addr u ) \ core
 \ used by dodefer:, must be defer  \ used by dodefer:, must be defer
   \G @i{c-addr} is the address of the input buffer and @i{u} is the
   \G number of characters in it.
   
 : (source) ( -- addr count )  : (source) ( -- c-addr u )
     tib #tib @ ;      tib #tib @ ;
 ' (source) IS source  ' (source) IS source
   [THEN]
   
 : (word) ( addr1 n1 char -- addr2 n2 )  : (word) ( addr1 n1 char -- addr2 n2 )
   dup >r skip 2dup r> scan  nip - ;    dup >r skip 2dup r> scan  nip - ;
Line 41  Defer source ( -- addr count ) \ core Line 51  Defer source ( -- addr count ) \ core
 \ (word) should fold white spaces  \ (word) should fold white spaces
 \ this is what (parse-white) does  \ this is what (parse-white) does
   
 \ word parse                                           23feb93py  \ parse                                           23feb93py
   
 : sword  ( char -- addr len ) \ gforth  : parse    ( char "ccc<char>" -- c-addr u ) \ core-ext
   \G parses like @code{word}, but the output is like @code{parse} output  \G Parse @i{ccc}, delimited by @i{char}, in the parse
   \ this word was called PARSE-WORD until 0.3.0, but Open Firmware and  \G area. @i{c-addr u} specifies the parsed string within the
   \ dpANS6 A.6.2.2008 have a word with that name that behaves  \G parse area. If the parse area was empty, @i{u} is 0.
   \ differently (like NAME).      >r  source  >in @ over min /string ( c-addr1 u1 )
   source 2dup >r >r >in @ over min /string      over  swap r>  scan >r
   rot dup bl = IF  drop (parse-white)  ELSE  (word)  THEN      over - dup r> IF 1+ THEN  >in +!
   2dup + r> - 1+ r> min >in ! ;  [ has? new-input [IF] ]
       2dup input-lexeme!
 : word   ( char -- addr ) \ core  [ [THEN] ] ;
   sword here place  bl here count + c!  here ;  
   
 : parse    ( char -- addr len ) \ core-ext  
   >r  source  >in @ over min /string  over  swap r>  scan >r  
   over - dup r> IF 1+ THEN  >in +! ;  
   
 \ name                                                 13feb93py  \ name                                                 13feb93py
   
 [IFUNDEF] (name) \ name might be a primitive  [IFUNDEF] (name) \ name might be a primitive
   
 : (name) ( -- c-addr count )  : (name) ( -- c-addr count ) \ gforth
     source 2dup >r >r >in @ /string (parse-white)      source 2dup >r >r >in @ /string (parse-white)
   [ has? new-input [IF] ]
       2dup input-lexeme!
   [ [THEN] ]
     2dup + r> - 1+ r> min >in ! ;      2dup + r> - 1+ r> min >in ! ;
 \    name count ;  \    name count ;
 [THEN]  [THEN]
Line 73  Defer source ( -- addr count ) \ core Line 81  Defer source ( -- addr count ) \ core
     dup 0= -&16 and throw ;      dup 0= -&16 and throw ;
   
 : name-too-long? ( c-addr u -- c-addr u )  : name-too-long? ( c-addr u -- c-addr u )
     dup $1F u> -&19 and throw ;      dup lcount-mask u> -&19 and throw ;
   
 \ \ Number parsing                                      23feb93py  \ \ Number parsing                                      23feb93py
   
 \ number? number                                       23feb93py  \ (number?) number                                       23feb93py
   
 hex  hex
 const Create bases   10 ,   2 ,   A , 100 ,  const Create bases   0A , 10 ,   2 ,   0A ,
 \                     16     2    10   character  \                    10   16     2     10
   
 \ !! protect BASE saving wrapper against exceptions  \ !! protect BASE saving wrapper against exceptions
 : getbase ( addr u -- addr' u' )  : getbase ( addr u -- addr' u' )
     over c@ [char] $ - dup 4 u<      2dup s" 0x" string-prefix? >r
       2dup s" 0X" string-prefix? r> or
       base @ &34 < and if
           hex 2 /string
       endif
       over c@ [char] # - dup 4 u<
     IF      IF
         cells bases + @ base ! 1 /string          cells bases + @ base ! 1 /string
     ELSE      ELSE
         drop          drop
     THEN ;      THEN ;
   
 : sign? ( addr u -- addr u flag )  : sign? ( addr u -- addr1 u1 flag )
     over c@ '- =  dup >r      over c@ [char] - =  dup >r
     IF      IF
         1 /string          1 /string
     THEN      THEN
     r> ;      r> ;
   
 : s>unumber? ( addr u -- ud flag )  : ?dnegate ( d1 f -- d2 )
     0. 2swap      if
     BEGIN ( d addr len )          dnegate
         dup >r >number dup      then ;
     WHILE \ there are characters left  
         dup r> -  has? os 0= [IF]
     WHILE \ the last >number parsed something  : x@+/string ( addr u -- addr' u' c )
         dup 1- dpl ! over c@ [char] . =      over c@ >r 1 /string r> ;
     WHILE \ the current char is '.'  [THEN]
         1 /string  
     REPEAT  THEN \ there are unparseable characters left  : s'>unumber? ( addr u -- ud flag )
         rdrop 2drop false      \ convert string "C" or "C'" to character code
       dup 0= if
           false exit
       endif
       x@+/string 0 s" '" 2rot string-prefix? ;
   
   : s>unumber? ( c-addr u -- ud flag ) \ gforth
       \G converts string c-addr u into ud, flag indicates success
       dpl on
       over c@ '' = if
           1 /string s'>unumber? exit
       endif
       base @ >r  getbase sign?
       over if
           >r 0. 2swap
           BEGIN ( d addr len )
               dup >r >number dup
           WHILE \ there are characters left
                   dup r> -
               WHILE \ the last >number parsed something
                       dup 1- dpl ! over c@ dp-char @ =
                   WHILE \ the current char is '.'
                           1 /string
                   REPEAT  THEN \ there are unparseable characters left
               2drop rdrop false
           ELSE
               rdrop 2drop r> ?dnegate true
           THEN
     ELSE      ELSE
         rdrop 2drop true          drop 2drop 0. false THEN
     THEN ;      r> base ! ;
   
 \ ouch, this is complicated; there must be a simpler way - anton  \ ouch, this is complicated; there must be a simpler way - anton
 : s>number? ( addr len -- d f )  : s>number? ( addr u -- d f ) \ gforth
     \ converts string addr len into d, flag indicates success      \G converts string addr u into d, flag indicates success
     base @ >r  dpl on   sign? >r  getbase      sign? >r
     s>unumber?      s>unumber?
     0= IF      0= IF
         false          rdrop false
     ELSE \ no characters left, all ok      ELSE \ no characters left, all ok
         r>          r> ?dnegate
         IF  
             dnegate  
         THEN  
         true          true
     THEN      THEN ;
     r> base ! ;  
   
 : s>number ( addr len -- d )  : s>number ( addr len -- d )
     \ don't use this, there is no way to tell success      \ don't use this, there is no way to tell success
Line 146  const Create bases   10 ,   2 ,   A , 10 Line 182  const Create bases   10 ,   2 ,   A , 10
         1+          1+
     THEN ;      THEN ;
   
 : number? ( string -- string 0 / n -1 / d 0> )  : (number?) ( string -- string 0 / n -1 / d 0> )
     dup >r count snumber? dup if      dup >r count snumber? dup if
         rdrop          rdrop
     else      else
Line 154  const Create bases   10 ,   2 ,   A , 10 Line 190  const Create bases   10 ,   2 ,   A , 10
     then ;      then ;
   
 : number ( string -- d )  : number ( string -- d )
     number? ?dup 0= abort" ?"  0<      (number?) ?dup 0= abort" ?"  0<
     IF      IF
         s>d          s>d
     THEN ;      THEN ;
   
 \ \ Comments ( \ \G  \ \ Comments ( \ \G
   
 : ( ( compilation 'ccc<close-paren>' -- ; run-time -- ) \ core,file     paren  : ( ( compilation 'ccc<close-paren>' -- ; run-time -- ) \ thisone- core,file    paren
     \G ** this will not get annotated. The alias in glocals.fs will instead **      \G ** this will not get annotated. The alias in glocals.fs will instead **
       \G It does not work to use "wordset-" prefix since this file is glossed
       \G by cross.fs which doesn't have the same functionalty as makedoc.fs
     [char] ) parse 2drop ; immediate      [char] ) parse 2drop ; immediate
   
 : \ ( -- ) \ core-ext,block-ext backslash  : \ ( compilation 'ccc<newline>' -- ; run-time -- ) \ thisone- core-ext,block-ext backslash
     \G ** this will not get annotated. The alias in glocals.fs will instead **      \G ** this will not get annotated. The alias in glocals.fs will instead ** 
       \G It does not work to use "wordset-" prefix since this file is glossed
       \G by cross.fs which doesn't have the same functionalty as makedoc.fs
     [ has? file [IF] ]      [ has? file [IF] ]
     blk @      blk @
     IF      IF
Line 176  const Create bases   10 ,   2 ,   A , 10 Line 216  const Create bases   10 ,   2 ,   A , 10
     [ [THEN] ]      [ [THEN] ]
     source >in ! drop ; immediate      source >in ! drop ; immediate
   
 : \G ( -- ) \ gforth backslash-gee  : \G ( compilation 'ccc<newline>' -- ; run-time -- ) \ gforth backslash-gee
     \G Equivalent to @code{\} but used as a tag to annotate definition      \G Equivalent to @code{\} but used as a tag to annotate definition
     \G comments into documentation.      \G comments into documentation.
     POSTPONE \ ; immediate      POSTPONE \ ; immediate
   
   has? ec [IF]
       AVariable forth-wordlist
       : find-name ( c-addr u -- nt | 0 ) \ gforth
           \g Find the name @i{c-addr u} in the current search
           \g order. Return its @i{nt}, if found, otherwise 0.
           forth-wordlist (f83find) ;
   [ELSE]
 \ \ object oriented search list                         17mar93py  \ \ object oriented search list                         17mar93py
   
 \ word list structure:  \ word list structure:
Line 200  struct Line 247  struct
   cell% field wordlist-extend \ wordlist extensions (eg bucket offset)    cell% field wordlist-extend \ wordlist extensions (eg bucket offset)
 end-struct wordlist-struct  end-struct wordlist-struct
   
   has? f83headerstring [IF]
 : f83find      ( addr len wordlist -- nt / false )  : f83find      ( addr len wordlist -- nt / false )
     wordlist-id @ (f83find) ;      wordlist-id @ (f83find) ;
   [ELSE]
   : f83find      ( addr len wordlist -- nt / false )
       wordlist-id @ (listlfind) ;
   [THEN]
   
 : initvoc               ( wid -- )  : initvoc               ( wid -- )
   dup wordlist-map @ hash-method perform ;    dup wordlist-map @ hash-method perform ;
Line 210  end-struct wordlist-struct Line 262  end-struct wordlist-struct
 Create f83search ( -- wordlist-map )  Create f83search ( -- wordlist-map )
     ' f83find A,  ' drop A,  ' drop A, ' drop A,      ' f83find A,  ' drop A,  ' drop A, ' drop A,
   
 here G f83search T A, NIL A, NIL A, NIL A,  here f83search A, NIL A, NIL A, NIL A,
 AValue forth-wordlist \ variable, will be redefined by search.fs  AValue forth-wordlist \ variable, will be redefined by search.fs
   
 AVariable lookup        forth-wordlist lookup !  AVariable lookup        forth-wordlist lookup !
 \ !! last is user and lookup?! jaw  \ !! last is user and lookup?! jaw
 AVariable current ( -- addr ) \ gforth  AVariable current ( -- addr ) \ gforth
 \G VARIABLE: holds the wid of the current compilation word list.  \G @code{Variable} -- holds the @i{wid} of the compilation word list.
 AVariable voclink       forth-wordlist wordlist-link voclink !  AVariable voclink       forth-wordlist wordlist-link voclink !
 lookup AValue context ( -- addr ) \ gforth  \ lookup AValue context ( -- addr ) \ gforth
 \G VALUE: @code{context} @code{@@} is the wid of the word list at the  Defer context ( -- addr ) \ gforth
 \G top of the search order stack.  \G @code{context} @code{@@} is the @i{wid} of the word list at the
   \G top of the search order.
   
   ' lookup is context
 forth-wordlist current !  forth-wordlist current !
   
   : (search-wordlist)  ( addr count wid -- nt | false )
       dup wordlist-map @ find-method perform ;
   
   : search-wordlist ( c-addr count wid -- 0 | xt +-1 ) \ search
       \G Search the word list identified by @i{wid} for the definition
       \G named by the string at @i{c-addr count}.  If the definition is
       \G not found, return 0. If the definition is found return 1 (if
       \G the definition is immediate) or -1 (if the definition is not
       \G immediate) together with the @i{xt}.  In Gforth, the @i{xt}
       \G returned represents the interpretation semantics.  ANS Forth
       \G does not specify clearly what @i{xt} represents.
       (search-wordlist) dup if
           (name>intn)
       then ;
   
   : find-name ( c-addr u -- nt | 0 ) \ gforth
       \g Find the name @i{c-addr u} in the current search
       \g order. Return its @i{nt}, if found, otherwise 0.
       lookup @ (search-wordlist) ;
   [THEN]
   
 \ \ header, finding, ticks                              17dec92py  \ \ header, finding, ticks                              17dec92py
   
 $80 constant alias-mask \ set when the word is not an alias!  \ The constants are defined as 32 bits, but then erased
 $40 constant immediate-mask  \ and overwritten by the right ones
 $20 constant restrict-mask  
   has? f83headerstring [IF]
       \ to save space, Gforth EC limits words to 31 characters
       \ also, there's no predule concept in Gforth EC
       $80 constant alias-mask
       $40 constant immediate-mask
       $20 constant restrict-mask
       $1f constant lcount-mask
   [ELSE]
   \ 32-bit systems cannot generate large 64-bit constant in the
   \ cross-compiler, so we kludge it by generating a constant and then
   \ storing the proper value into it (and that's another kludge).
   $80000000 constant alias-mask
   1 bits/char 1 - lshift
   -1 cells allot  bigendian [IF]   c, 0 1 cells 1- times
                             [ELSE] 0 1 cells 1- times c, [THEN]
   $40000000 constant immediate-mask
   1 bits/char 2 - lshift
   -1 cells allot  bigendian [IF]   c, 0 1 cells 1- times
                             [ELSE] 0 1 cells 1- times c, [THEN]
   $20000000 constant restrict-mask
   1 bits/char 3 - lshift
   -1 cells allot  bigendian [IF]   c, 0 1 cells 1- times
                             [ELSE] 0 1 cells 1- times c, [THEN]
   $10000000 constant prelude-mask
   1 bits/char 4 - lshift
   -1 cells allot  bigendian [IF]   c, 0 1 cells 1- times
                             [ELSE] 0 1 cells 1- times c, [THEN]
   $0fffffff constant lcount-mask
   1 bits/char 4 - lshift 1 -
   -1 cells allot  bigendian [IF]   c, -1 1 cells 1- times
                             [ELSE] -1 1 cells 1- times c, [THEN]
   [THEN]
   
 \ higher level parts of find  \ higher level parts of find
   
Line 236  $20 constant restrict-mask Line 343  $20 constant restrict-mask
     \ true becomes 1, false -1      \ true becomes 1, false -1
     0= 2* 1+ ;      0= 2* 1+ ;
   
   : ticking-compile-only-error ( ... -- )
       -&2048 throw ;
   
 : compile-only-error ( ... -- )  : compile-only-error ( ... -- )
     -&14 throw ;      -&14 throw ;
   
Line 247  $20 constant restrict-mask Line 357  $20 constant restrict-mask
     then       then 
 [ [THEN] ] ;  [ [THEN] ] ;
   
 : (x>int) ( cfa b -- xt )  : (x>int) ( cfa w -- xt )
     \ get interpretation semantics of name      \ get interpretation semantics of name
     restrict-mask and      restrict-mask and [ has? rom [IF] ] 0= [ [THEN] ]
     if      if
         drop ['] compile-only-error          drop ['] compile-only-error
     else      else
         (cfa>int)          (cfa>int)
     then ;      then ;
   
 : name>string ( nt -- addr count ) \ gforth     head-to-string  has? f83headerstring [IF]
     \g @var{addr count} is the name of the word represented by @var{nt}.  : name>string ( nt -- addr count ) \ gforth     name-to-string
     cell+ count $1F and ;      \g @i{addr count} is the name of the word represented by @i{nt}.
       cell+ count lcount-mask and ;
   
 : ((name>))  ( nfa -- cfa )  : ((name>))  ( nfa -- cfa )
     name>string + cfaligned ;      name>string + cfaligned ;
   
 : (name>x) ( nfa -- cfa b )  : (name>x) ( nfa -- cfa w )
     \ cfa is an intermediate cfa and b is the flags byte of nfa      \ cfa is an intermediate cfa and w is the flags cell of nfa
     dup ((name>))      dup ((name>))
     swap cell+ c@ dup alias-mask and 0=      swap cell+ c@ dup alias-mask and 0=
     IF      IF
         swap @ swap          swap @ swap
     THEN ;      THEN ;
   [ELSE]
   : name>string ( nt -- addr count ) \ gforth     name-to-string
       \g @i{addr count} is the name of the word represented by @i{nt}.
       cell+ dup cell+ swap @ lcount-mask and ;
   
   : ((name>))  ( nfa -- cfa )
       name>string + cfaligned ;
   
   : (name>x) ( nfa -- cfa w )
       \ cfa is an intermediate cfa and w is the flags cell of nfa
       dup ((name>))
       swap cell+ @ dup alias-mask and 0=
       IF
           swap @ swap
       THEN ;
   [THEN]
   
 : name>int ( nt -- xt ) \ gforth  : name>int ( nt -- xt ) \ gforth name-to-int
     \G @var{xt} represents the interpretation semantics of the word      \G @i{xt} represents the interpretation semantics of the word
     \G @var{nt}. Produces @code{' compile-only-error} if      \G @i{nt}. If @i{nt} has no interpretation semantics (i.e. is
     \G @var{nt} is compile-only.      \G @code{compile-only}), @i{xt} is the execution token for
       \G @code{ticking-compile-only-error}, which performs @code{-2048 throw}.
     (name>x) (x>int) ;      (name>x) (x>int) ;
   
 : name?int ( nt -- xt ) \ gforth  : name?int ( nt -- xt ) \ gforth name-question-int
     \G Like name>int, but throws an error if compile-only.      \G Like @code{name>int}, but perform @code{-2048 throw} if @i{nt}
     (name>x) restrict-mask and      \G has no interpretation semantics.
       (name>x) restrict-mask and [ has? rom [IF] ] 0= [ [THEN] ]
     if      if
         compile-only-error \ does not return          ticking-compile-only-error \ does not return
     then      then
     (cfa>int) ;      (cfa>int) ;
   
 : (name>comp) ( nt -- w +-1 ) \ gforth  : (name>comp) ( nt -- w +-1 ) \ gforth
     \G @var{w xt} is the compilation token for the word @var{nt}.      \G @i{w xt} is the compilation token for the word @i{nt}.
     (name>x) >r       (name>x) >r 
 [ has? compiler [IF] ]  [ has? compiler [IF] ]
     dup interpret/compile?      dup interpret/compile?
Line 294  $20 constant restrict-mask Line 423  $20 constant restrict-mask
         interpret/compile-comp @          interpret/compile-comp @
     then       then 
 [ [THEN] ]  [ [THEN] ]
     r> immediate-mask and flag-sign      r> immediate-mask and [ has? rom [IF] ] 0= [ [THEN] ] flag-sign
     ;      ;
   
 : (name>intn) ( nfa -- xt +-1 )  : (name>intn) ( nfa -- xt +-1 )
     (name>x) tuck (x>int) ( b xt )      (name>x) tuck (x>int) ( w xt )
     swap immediate-mask and flag-sign ;      swap immediate-mask and [ has? rom [IF] ] 0= [ [THEN] ] flag-sign ;
   
   [IFDEF] prelude-mask
   : name>prelude ( nt -- xt )
       dup cell+ @ prelude-mask and if
           [ -1 cells ] literal + @
       else
           drop ['] noop
       then ;
   [THEN]
   
   const Create ???  0 , 3 , char ? c, char ? c, char ? c,
   \ ??? is used by dovar:, must be created/:dovar
   
   [IFDEF] forthstart
   \ if we have a forthstart we can define head? with it
   \ otherwise leave out the head? check
   
   : one-head? ( addr -- f )
   \G heuristic check whether addr is a name token; may deliver false
   \G positives; addr must be a valid address
       dup dup aligned <>
       if
           drop false exit \ heads are aligned
       then
       dup cell+ @ alias-mask and 0= >r
       name>string dup $20 $1 within if
           rdrop 2drop false exit \ realistically the name is short
       then
       over + cfaligned over - 2dup bounds ?do \ should be a printable string
           i c@ bl < if
               2drop unloop rdrop false exit
           then
       loop
       + r> if \ check for valid aliases
           @ dup forthstart here within
           over ['] noop ['] lit-execute 1+ within or
           over dup aligned = and
           0= if
               drop false exit
           then
       then \ check for cfa - must be code field or primitive
       dup @ tuck 2 cells - = swap
       docol:  ['] lit-execute @ 1+ within or ;
   
 : head? ( addr -- f )  : head? ( addr -- f )
     \G heuristic check whether addr is a name token; may deliver false  \G heuristic check whether addr is a name token; may deliver false
     \G positives; addr must be a valid address  \G positives; addr must be a valid address; returns 1 for
   \G particularly unsafe positives
     \ we follow the link fields and check for plausibility; two      \ we follow the link fields and check for plausibility; two
     \ iterations should catch most false addresses: on the first      \ iterations should catch most false addresses: on the first
     \ iteration, we may get an xt, on the second a code address (or      \ iteration, we may get an xt, on the second a code address (or
     \ some code), which is typically not in the dictionary.      \ some code), which is typically not in the dictionary.
     2 0 do      \ we added a third iteration for working with code and ;code words.
         dup @ dup      3 0 do
         if ( addr addr1 )          dup one-head? 0= if
             dup rot forthstart within              drop false unloop exit
             if \ addr1 is outside forthstart..addr, not a head          endif
           dup @ dup 0= if
               2drop 1 unloop exit
           else
               dup rot forthstart within if
                 drop false unloop exit                  drop false unloop exit
             then ( addr1 )              then
         else \ 0 in the link field, no further checks  
             2drop true unloop exit  
         then          then
     loop      loop
     \ in dubio pro:  
     drop true ;      drop true ;
   
 const Create ???  0 , 3 c, char ? c, char ? c, char ? c,  : >head-noprim ( cfa -- nt ) \ gforth  to-head-noprim
 \ ??? is used by dovar:, must be created/:dovar      \ also heuristic
       dup forthstart - max-name-length @
 : >head ( cfa -- nt ) \ gforth  to-head      [ has? float [IF] ] float+ [ [ELSE] ] cell+ [ [THEN] ] cell+ min
     $21 cell do ( cfa )      cell max cell ?do ( cfa )
         dup i - count $9F and + cfaligned over alias-mask + =          dup i - dup @ [ alias-mask lcount-mask or ] literal
           [ 1 bits/char 3 - lshift 1 - 1 bits/char 1 - lshift or
           -1 cells allot bigendian [IF]   c, -1 1 cells 1- times
           [ELSE] -1 1 cells 1- times c, [THEN] ]
           and ( cfa len|alias )
           swap + cell+ cfaligned over alias-mask + =
         if ( cfa )          if ( cfa )
             dup i - cell - dup head?              dup i - cell - dup head?
             if              if
Line 338  const Create ???  0 , 3 c, char ? c, cha Line 517  const Create ???  0 , 3 c, char ? c, cha
         cell +loop          cell +loop
     drop ??? ( wouldn't 0 be better? ) ;      drop ??? ( wouldn't 0 be better? ) ;
   
 ' >head ALIAS >name  [ELSE]
   
 : body> 0 >body - ;  : >head-noprim ( cfa -- nt ) \ gforth  to-head-noprim
       $25 cell do ( cfa )
           dup i - dup @ [ alias-mask lcount-mask or ] literal
           [ 1 bits/char 3 - lshift 1 - 1 bits/char 1 - lshift or
           -1 cells allot bigendian [IF]   c, -1 1 cells 1- times
           [ELSE] -1 1 cells 1- times c, [THEN] ]
           and ( cfa len|alias )
           swap + cell + cfaligned over alias-mask + =
           if ( cfa ) i - cell - unloop exit
           then
           cell +loop
       drop ??? ( wouldn't 0 be better? ) ;
   
 : (search-wordlist)  ( addr count wid -- nt / false )  [THEN]
     dup wordlist-map @ find-method perform ;  
   
 : search-wordlist ( c-addr count wid -- 0 / xt +-1 ) \ search  cell% 2* 0 0 field >body ( xt -- a_addr ) \ core to-body
     \G Search the word list identified by wid  \G Get the address of the body of the word represented by @i{xt} (the
     \G for the definition named by the string at c-addr count.  \G address of the word's data field).
     \G If the definition is not found, return 0. If the definition  drop drop
     \G is found return 1 (if the definition is immediate) or -1  
     \G (if the definition is not immediate) together with the xt.  cell% -2 * 0 0 field body> ( xt -- a_addr )
     \G The xt returned represents the interpretation semantics.      drop drop
     (search-wordlist) dup if  
         (name>intn)  has? standardthreading has? compiler and [IF]
     then ;  
   ' @ alias >code-address ( xt -- c_addr ) \ gforth
   \G @i{c-addr} is the code address of the word @i{xt}.
   
   : >does-code ( xt -- a_addr ) \ gforth
   \G If @i{xt} is the execution token of a child of a @code{DOES>} word,
   \G @i{a-addr} is the start of the Forth code after the @code{DOES>};
   \G Otherwise @i{a-addr} is 0.
       dup @ dodoes: = if
           cell+ @
       else
           drop 0
       endif ;
   
 : find-name ( c-addr u -- nt/0 ) \ gforth  has? prims [IF]
     \g Find the name @var{c-addr u} in the current search      : flash! ! ;
     \g order. Return its nt, if found, otherwise 0.      : flashc! c! ;
     lookup @ (search-wordlist) ;  [THEN]
   
   has? flash [IF] ' flash! [ELSE] ' ! [THEN]
   alias code-address! ( c_addr xt -- ) \ gforth
   \G Create a code field with code address @i{c-addr} at @i{xt}.
   
   : any-code! ( a-addr cfa code-addr -- )
       \ for implementing DOES> and ;ABI-CODE, maybe :
       \ code-address is stored at cfa, a-addr at cfa+cell
       over ! cell+ ! ;
       
   : does-code! ( a-addr xt -- ) \ gforth
   \G Create a code field at @i{xt} for a child of a @code{DOES>}-word;
   \G @i{a-addr} is the start of the Forth code after @code{DOES>}.
       [ has? flash [IF] ]
       dodoes: over flash! cell+ flash!
       [ [ELSE] ]
       dodoes: any-code! 
       [ [THEN] ] ;
   
   2 cells constant /does-handler ( -- n ) \ gforth
   \G The size of a @code{DOES>}-handler (includes possible padding).
   
   [THEN]  
   
 : sfind ( c-addr u -- 0 / xt +-1  ) \ gforth-obsolete  : sfind ( c-addr u -- 0 / xt +-1  ) \ gforth-obsolete
     find-name dup      find-name dup
Line 372  const Create ???  0 , 3 c, char ? c, cha Line 596  const Create ???  0 , 3 c, char ? c, cha
         then          then
    then ;     then ;
   
 : find ( c-addr -- xt +-1 / c-addr 0 ) \ core,search  : find ( c-addr -- xt +-1 | c-addr 0 ) \ core,search
     \G Search all word lists in the current search order      \G Search all word lists in the current search order for the
     \G for the definition named by the counted string at c-addr.      \G definition named by the counted string at @i{c-addr}.  If the
     \G If the definition is not found, return 0. If the definition      \G definition is not found, return 0. If the definition is found
     \G is found return 1 (if the definition is immediate) or -1      \G return 1 (if the definition has non-default compilation
     \G (if the definition is not immediate) together with the xt.      \G semantics) or -1 (if the definition has default compilation
       \G semantics).  The @i{xt} returned in interpret state represents
       \G the interpretation semantics.  The @i{xt} returned in compile
       \G state represented either the compilation semantics (for
       \G non-default compilation semantics) or the run-time semantics
       \G that the compilation semantics would @code{compile,} (for
       \G default compilation semantics).  The ANS Forth standard does
       \G not specify clearly what the returned @i{xt} represents (and
       \G also talks about immediacy instead of non-default compilation
       \G semantics), so this word is questionable in portable programs.
       \G If non-portability is ok, @code{find-name} and friends are
       \G better (@pxref{Name token}).
     dup count sfind dup      dup count sfind dup
     if      if
         rot drop          rot drop
     then ;      then ;
   
 \ ticks  \ ticks in interpreter
   
 : (') ( "name" -- nt ) \ gforth  : (') ( "name" -- nt ) \ gforth
     name find-name dup 0=      parse-name name-too-short?
       find-name dup 0=
     IF      IF
         drop -&13 bounce          drop -&13 throw
     THEN  ;      THEN  ;
   
 : '    ( "name" -- xt ) \ core  tick  : '    ( "name" -- xt ) \ core  tick
     \g @var{xt} represents @var{name}'s interpretation      \g @i{xt} represents @i{name}'s interpretation
     \g semantics. Performs @code{-14 throw} if the word has no      \g semantics. Perform @code{-14 throw} if the word has no
     \g interpretation semantics.      \g interpretation semantics.
     (') name?int ;      (') name?int ;
   
   has? compiler 0= [IF]   \ interpreter only version of IS and TO
   
   : IS ' >body ! ;
   ' IS Alias TO
   
   [THEN]
   
 \ \ the interpreter loop                                  mar92py  \ \ the interpreter loop                                  mar92py
   
 \ interpret                                            10mar92py  \ interpret                                            10mar92py
   
 Defer parser  Defer parser1 ( c-addr u -- ... xt)
 Defer name ( -- c-addr count ) \ gforth  \ "... xt" is the action to be performed by the text-interpretation of c-addr u
 \ get the next word from the input buffer  
 ' (name) IS name  
 Defer compiler-notfound ( c-addr count -- )  
 Defer interpreter-notfound ( c-addr count -- )  
   
   : parser ( c-addr u -- ... )
   \ text-interpret the word/number c-addr u, possibly producing a number
       parser1 execute ;
   has? ec [IF]
       ' (name) Alias parse-name
       : no.extensions  2drop -&13 throw ;
       ' no.extensions Alias compiler-notfound1
       ' no.extensions Alias interpreter-notfound1
   [ELSE]    
   Defer parse-name ( "name" -- c-addr u ) \ gforth
   \G Get the next word from the input buffer
   ' (name) IS parse-name
   
   ' parse-name alias parse-word ( -- c-addr u ) \ gforth-obsolete
   \G old name for @code{parse-name}
       
   ' parse-name alias name ( -- c-addr u ) \ gforth-obsolete
   \G old name for @code{parse-name}
       
 : no.extensions  ( addr u -- )  : no.extensions  ( addr u -- )
     2drop -&13 bounce ;      2drop -&13 throw ;
 ' no.extensions IS compiler-notfound  
 ' no.extensions IS interpreter-notfound  has? recognizer 0= [IF]
   Defer compiler-notfound1 ( c-addr count -- ... xt )
   Defer interpreter-notfound1 ( c-addr count -- ... xt )
   
   ' no.extensions IS compiler-notfound1
   ' no.extensions IS interpreter-notfound1
   [THEN]
   
   Defer before-word ( -- ) \ gforth
   \ called before the text interpreter parses the next word
   ' noop IS before-word
   
   Defer before-line ( -- ) \ gforth
   \ called before the text interpreter parses the next line
   ' noop IS before-line
   
   [THEN]
   
   has? backtrace [IF]
   : interpret1 ( ... -- ... )
       rp@ backtrace-rp0 !
       [ has? EC 0= [IF] ] before-line [ [THEN] ]
       BEGIN
           ?stack [ has? EC 0= [IF] ] before-word [ [THEN] ] parse-name dup
       WHILE
           parser1 execute
       REPEAT
       2drop ;
       
 : interpret ( ?? -- ?? ) \ gforth  : interpret ( ?? -- ?? ) \ gforth
     \ interpret/compile the (rest of the) input buffer      \ interpret/compile the (rest of the) input buffer
       backtrace-rp0 @ >r  
       ['] interpret1 catch
       r> backtrace-rp0 !
       throw ;
   [ELSE]
   : interpret ( ... -- ... )
     BEGIN      BEGIN
         ?stack name dup          ?stack [ has? EC 0= [IF] ] before-word [ [THEN] ] parse-name dup
     WHILE      WHILE
         parser          parser1 execute
     REPEAT      REPEAT
     2drop ;      2drop ;
   [THEN]
   
 \ interpreter                                   30apr92py  \ interpreter                                   30apr92py
   
   [IFDEF] prelude-mask
   : run-prelude ( nt|0 -- nt|0 )
       \ run the prelude of the name identified by nt (if present).  This
       \ is used in the text interpreter and similar stuff.
       dup if
           dup name>prelude execute
       then ;
   [THEN]
   
   has? recognizer 0= [IF]
 \ not the most efficient implementations of interpreter and compiler  \ not the most efficient implementations of interpreter and compiler
 | : interpreter ( c-addr u -- )   : interpreter1 ( c-addr u -- ... xt ) 
     2dup find-name dup      2dup find-name [ [IFDEF] prelude-mask ] run-prelude [ [THEN] ] dup
     if      if
         nip nip name>int execute          nip nip name>int
     else      else
         drop          drop
         2dup 2>r snumber?          2dup 2>r snumber?
         IF          IF
             2rdrop              2rdrop ['] noop
         ELSE          ELSE
             2r> interpreter-notfound              2r> interpreter-notfound1
         THEN          THEN
     then ;      then ;
   
 ' interpreter  IS  parser  ' interpreter1  IS  parser1
   [THEN]
   
 \ \ Query Evaluate                                      07apr93py  \ \ Query Evaluate                                      07apr93py
   
 has? file 0= [IF]  has? file 0= [IF]
 : sourceline# ( -- n )  1 ;  : sourceline# ( -- n )  1 ;
   [ELSE]
   has? new-input 0= [IF]
   Variable #fill-bytes
   \G number of bytes read via (read-line) by the last refill
   [THEN]
 [THEN]  [THEN]
   
   has? new-input 0= [IF]
   : input-start-line ( -- )  >in off ;
 : refill ( -- flag ) \ core-ext,block-ext,file-ext  : refill ( -- flag ) \ core-ext,block-ext,file-ext
       \G Attempt to fill the input buffer from the input source.  When
       \G the input source is the user input device, attempt to receive
       \G input into the terminal input device. If successful, make the
       \G result the input buffer, set @code{>IN} to 0 and return true;
       \G otherwise return false. When the input source is a block, add 1
       \G to the value of @code{BLK} to make the next block the input
       \G source and current input buffer, and set @code{>IN} to 0;
       \G return true if the new value of @code{BLK} is a valid block
       \G number, false otherwise. When the input source is a text file,
       \G attempt to read the next line from the file. If successful,
       \G make the result the current input buffer, set @code{>IN} to 0
       \G and return true; otherwise, return false.  A successful result
       \G includes receipt of a line containing 0 characters.
     [ has? file [IF] ]      [ has? file [IF] ]
         blk @  IF  1 blk +!  true  0 >in !  EXIT  THEN          blk @  IF  1 blk +!  true  EXIT  THEN
         [ [THEN] ]          [ [THEN] ]
     tib /line      tib /line
     [ has? file [IF] ]      [ has? file [IF] ]
         loadfile @ ?dup          loadfile @ ?dup
         IF    read-line throw          IF    (read-line) throw #fill-bytes !
         ELSE          ELSE
             [ [THEN] ]              [ [THEN] ]
         sourceline# 0< IF 2drop false EXIT THEN          sourceline# 0< IF 2drop false EXIT THEN
         accept true          accept eof @ 0=
         [ has? file [IF] ]          [ has? file [IF] ]
         THEN          THEN
         1 loadline +!          1 loadline +!
         [ [THEN] ]          [ [THEN] ]
     swap #tib ! 0 >in ! ;      swap #tib !
       input-start-line ;
   
 : query   ( -- ) \ core-ext  : query   ( -- ) \ core-ext
     \G obsolescent      \G Make the user input device the input source. Receive input into
       \G the Terminal Input Buffer. Set @code{>IN} to zero. OBSOLESCENT:
       \G superceeded by @code{accept}.
     [ has? file [IF] ]      [ has? file [IF] ]
         blk off loadfile off          blk off loadfile off
         [ [THEN] ]          [ [THEN] ]
     tib /line accept #tib ! 0 >in ! ;      refill drop ;
   [THEN]
   
 \ save-mem extend-mem  \ save-mem extend-mem
   
Line 481  has? os [IF] Line 808  has? os [IF]
     dup allocate throw      dup allocate throw
     swap 2dup r> -rot move ;      swap 2dup r> -rot move ;
   
   : free-mem-var ( addr -- )
       \ addr is the address of a 2variable containing address and size
       \ of a memory range; frees memory and clears the 2variable.
       dup 2@ drop dup
       if ( addr mem-start )
           free throw
           0 0 rot 2!
       else
           2drop
       then ;
   
 : extend-mem    ( addr1 u1 u -- addr addr2 u2 )  : extend-mem    ( addr1 u1 u -- addr addr2 u2 )
     \ extend memory block allocated from the heap by u aus      \ extend memory block allocated from the heap by u aus
     \ the (possibly reallocated piece is addr2 u2, the extension is at addr      \ the (possibly reallocated) piece is addr2 u2, the extension is at addr
     over >r + dup >r resize throw      over >r + dup >r resize throw
     r> over r> + -rot ;      r> over r> + -rot ;
 [THEN]  [THEN]
   
 \ EVALUATE                                              17may93jaw  \ EVALUATE                                              17may93jaw
   
 has? file 0= [IF]  has? file 0= has? new-input 0= and [IF]
 : push-file  ( -- )  r>  : push-file  ( -- )  r>
   tibstack @ >r  >tib @ >r  #tib @ >r    tibstack @ >r  >tib @ >r  #tib @ >r
   >tib @ tibstack @ = IF  r@ tibstack +!  THEN    >tib @ tibstack @ = IF  r@ tibstack +!  THEN
Line 501  has? file 0= [IF] Line 839  has? file 0= [IF]
   r> >in !  r> #tib !  r> >tib !  r> tibstack !  >r ;    r> >in !  r> #tib !  r> >tib !  r> tibstack !  >r ;
 [THEN]  [THEN]
   
 : evaluate ( c-addr len -- ) \ core,block  has? new-input 0= [IF]
   push-file  #tib ! >tib !  : evaluate ( c-addr u -- ) \ core,block
   >in off      \G Save the current input source specification. Store @code{-1} in
   [ has? file [IF] ]      \G @code{source-id} and @code{0} in @code{blk}. Set @code{>IN} to
       blk off loadfile off -1 loadline !      \G @code{0} and make the string @i{c-addr u} the input source
       [ [THEN] ]      \G and input buffer. Interpret. When the parse area is empty,
   ['] interpret catch      \G restore the input source specification.
   pop-file throw ;  [ has? file [IF] ]
       s" *evaluated string*" loadfilename>r
   [ [THEN] ]
       push-file #tib ! >tib !
       input-start-line
       [ has? file [IF] ]
           blk off loadfile off -1 loadline !
           [ [THEN] ]
       ['] interpret catch
       pop-file
   [ has? file [IF] ]
       r>loadfilename
   [ [THEN] ]
       throw ;
   [THEN]
   
 \ \ Quit                                                13feb93py  \ \ Quit                                                13feb93py
   
 Defer 'quit  Defer 'quit
   
 Defer .status  has? os [IF]
       Defer .status
   [ELSE]
       [IFUNDEF] bye
           : (bye)     ( 0 -- ) \ back to DOS
               drop 5 emit ;
           
           : bye ( -- )  0 (bye) ;
       [THEN]
   [THEN]
   
 : prompt        state @ IF ."  compiled" EXIT THEN ."  ok" ;  : prompt        state @ IF ."  compiled" EXIT THEN ."  ok" ;
   
 : (Query)  ( -- )  : (quit) ( -- )
     [ has? file [IF] ]      \ exits only through THROW etc.
         loadfile off  blk off loadline off      BEGIN
         [ [THEN] ]          [ has? ec [IF] ] cr [ [ELSE] ]
     refill drop ;          .status ['] cr catch if
               [ has? OS [IF] ] >stderr [ [THEN] ]
 : (quit)  BEGIN  .status cr (query) interpret prompt  AGAIN ;              cr ." Can't print to stdout, leaving" cr
               \ if stderr does not work either, already DoError causes a hang
               -2 (bye)
           endif [ [THEN] ]
           refill  WHILE
               interpret prompt
       REPEAT
       bye ;
   
 ' (quit) IS 'quit  ' (quit) IS 'quit
   
 \ \ DOERROR (DOERROR)                                   13jun93jaw  \ \ DOERROR (DOERROR)                                   13jun93jaw
   
   has? os [IF]
 8 Constant max-errors  8 Constant max-errors
   5 has? file 2 and + Constant /error
 Variable error-stack  0 error-stack !  Variable error-stack  0 error-stack !
 max-errors 6 * cells allot  max-errors /error * cells allot
 \ format of one cell:  \ format of one cell:
 \ source ( addr u )  \ source ( c-addr u )
 \ >in  \ last parsed lexeme ( c-addr u )
 \ line-number  \ line-number
 \ Loadfilename ( addr u )  \ Loadfilename ( addr u )
   
   : error> ( --  c-addr1 u1 c-addr2 u2 line# [addr u] )
       -1 error-stack +!
       error-stack dup @
       /error * cells + cell+
       /error cells bounds DO
           I @
       cell +LOOP ;
   
   : >error ( c-addr1 u1 c-addr2 u2 line# [addr u] -- )
       error-stack dup @ dup 1+
       max-errors 1- min error-stack !
       /error * cells + cell+
       /error 1- cells bounds swap DO
           I !
       -1 cells +LOOP ;
   
   : input-error-data ( -- c-addr1 u1 c-addr2 u2 line# [addr u] )
       \ error data for the current input, to be used by >error or .error-frame
       source over >r save-mem over r> -
       input-lexeme 2@ >r + r> sourceline#
       [ has? file [IF] ] sourcefilename [ [THEN] ] ;
   
 : dec. ( n -- ) \ gforth  : dec. ( n -- ) \ gforth
     \G Display n as a signed decimal number, followed by a space.      \G Display @i{n} as a signed decimal number, followed by a space.
       \ !! not used...
     base @ decimal swap . base ! ;      base @ decimal swap . base ! ;
   
   : dec.r ( u n -- ) \ gforth
       \G Display @i{u} as a unsigned decimal number in a field @i{n}
       \G characters wide.
       base @ >r decimal .r r> base ! ;
   
 : hex. ( u -- ) \ gforth  : hex. ( u -- ) \ gforth
     \G Display u as an unsigned hex number, prefixed with a "$" and      \G Display @i{u} as an unsigned hex number, prefixed with a "$" and
     \G followed by a space.      \G followed by a space.
     '$ emit base @ swap hex u. base ! ;      \ !! not used...
       [char] $ emit base @ swap hex u. base ! ;
   
 : typewhite ( addr u -- ) \ gforth  : -trailing  ( c_addr u1 -- c_addr u2 ) \ string dash-trailing
     \ like type, but white space is printed instead of the characters  \G Adjust the string specified by @i{c-addr, u1} to remove all
     bounds ?do  \G trailing spaces. @i{u2} is the length of the modified string.
         i c@ #tab = if \ check for tab      BEGIN
             #tab          dup
         else      WHILE
             bl          1- 2dup + c@ bl <>
         then      UNTIL  1+  THEN ;
         emit  
     loop ;  
   
 DEFER DOERROR  DEFER DOERROR
   
   has? backtrace [IF]
 Defer dobacktrace ( -- )  Defer dobacktrace ( -- )
 ' noop IS dobacktrace  ' noop IS dobacktrace
   [THEN]
   
 : .error-frame ( addr1 u1 n1 n2 addr2 u2 -- )  : .error-string ( throw-code -- )
   cr error-stack @    dup -2 = 
   IF    IF    "error @ ?dup IF count type  THEN drop
      ." in file included from "    ELSE  .error
      type ." :" dec.  drop 2drop    THEN ;
   ELSE  
      type ." :" dec.  [IFUNDEF] umin
      cr dup 2over type cr drop  : umin ( u1 u2 -- u )
      nip -trailing 1- ( line-start index2 )      2dup u>
      0 >r  BEGIN      if
                   2dup + c@ bl >  WHILE          swap
                   r> 1+ >r  1- dup 0<  UNTIL  THEN  1+      then
      ( line-start index1 )      drop ;
      typewhite  [THEN]
      r> 1 max 0 ?do \ we want at least one "^", even if the length is 0  
                   [char] ^ emit  Defer mark-start
      loop  Defer mark-end
   THEN  
 ;  :noname ." >>>" ; IS mark-start
   :noname ." <<<" ; IS mark-end
   
   : part-type ( addr1 u1 u -- addr2 u2 )
       \ print first u characters of addr1 u1, addr2 u2 is the rest
       over umin 2 pick over type /string ;
   
   : .error-line ( c-addr1 u1 c-addr2 u2 -- )
       \ print error in line c-addr1 u1, where the error-causing lexeme
       \ is c-addr2 u2
       >r 2 pick - part-type ( c-addr3 u3 R: u2 )
       mark-start r> part-type mark-end ( c-addr4 u4 )
       type ;
   
   : .error-frame ( throwcode addr1 u1 addr2 u2 n2 [addr3 u3] -- throwcode )
       \ addr3 u3: filename of included file - optional
       \ n2:       line number
       \ addr2 u2: parsed lexeme (should be marked as causing the error)
       \ addr1 u1: input line
       error-stack @
       IF ( throwcode addr1 u1 n0 n1 n2 [addr2 u2] )
           [ has? file [IF] ] \ !! unbalanced stack effect
             over IF
                 cr ." in file included from "
                 type ." :"
                 0 dec.r  2drop 2drop
             ELSE
                 2drop 2drop 2drop drop
             THEN
             [ [THEN] ] ( throwcode addr1 u1 n0 n1 n2 )
       ELSE ( throwcode addr1 u1 n0 n1 n2 [addr2 u2] )
           [ has? file [IF] ]
               cr type ." :"
               [ [THEN] ] ( throwcode addr1 u1 n0 n1 n2 )
           dup 0 dec.r ." : " 5 pick .error-string
           IF \ if line# non-zero, there is a line
               cr .error-line
           ELSE
               2drop 2drop
           THEN
       THEN ;
   
 : (DoError) ( throw-code -- )  : (DoError) ( throw-code -- )
   [ has? os [IF] ]    [ has? os [IF] ]
       >stderr        >stderr
   [ [THEN] ]     [ [THEN] ] 
   sourceline# IF    input-error-data .error-frame
       source >in @ sourceline# 0 0 .error-frame  
   THEN  
   error-stack @ 0 ?DO    error-stack @ 0 ?DO
     -1 error-stack +!      error>
     error-stack dup @ 6 * cells + cell+  
     6 cells bounds DO  
       I @  
     cell +LOOP  
     .error-frame      .error-frame
   LOOP    LOOP
   dup -2 =    drop 
   IF   [ has? backtrace [IF] ]
      "error @ ?dup  
      IF  
         cr count type   
      THEN  
      drop  
   ELSE  
      .error  
   THEN  
   dobacktrace    dobacktrace
   [ [THEN] ]
   normal-dp dpp ! ;    normal-dp dpp ! ;
   
 ' (DoError) IS DoError  ' (DoError) IS DoError
   
   [ELSE]
       : dec.  base @ >r decimal . r> base ! ;
       : DoError ( throw-code -- )
           cr source drop >in @ type ." <<< "
           dup -2 =  IF  "error @ type  drop  EXIT  THEN
           .error ;
   [THEN]
   
 : quit ( ?? -- ?? ) \ core  : quit ( ?? -- ?? ) \ core
     rp0 @ rp! handler off clear-tibstack >tib @ >r      \G Empty the return stack, make the user input device
       \G the input source, enter interpret state and start
       \G the text interpreter.
       rp0 @ rp! handler off clear-tibstack
       [ has? new-input 0= [IF] ] >tib @ >r [ [THEN] ]
     BEGIN      BEGIN
         [ has? compiler [IF] ]          [ has? compiler [IF] ]
         postpone [              [compile] [
         [ [THEN] ]          [ [THEN] ]
           \ stack depths may be arbitrary here
         ['] 'quit CATCH dup          ['] 'quit CATCH dup
     WHILE      WHILE
         DoError r@ >tib ! r@ tibstack !              <# \ reset hold area, or we may get another error
               DoError
               \ stack depths may be arbitrary still (or again), so clear them
               clearstacks
               [ has? new-input [IF] ] clear-tibstack
               [ [ELSE] ] r@ >tib ! r@ tibstack !
               [ [THEN] ]
     REPEAT      REPEAT
     drop r> >tib ! ;      drop [ has? new-input [IF] ] clear-tibstack
       [ [ELSE] ] r> >tib !
       [ [THEN] ] ;
   
   : do-execute ( xt -- ) \ Gforth
       \G C calling us
       catch dup IF  DoError cr  THEN  (bye) ;
   
   : do-find ( addr u -- )
       find-name dup IF  name>int  THEN  (bye) ;
   
 \ \ Cold Boot                                           13feb93py  \ \ Cold Boot                                           13feb93py
   
 : (bootmessage)  : gforth ( -- )
     ." GForth " version-string type       ." Gforth " version-string type 
     ." , Copyright (C) 1998 Free Software Foundation, Inc." cr      ." , Copyright (C) 1995-2012 Free Software Foundation, Inc." cr
     ." GForth comes with ABSOLUTELY NO WARRANTY; for details type `license'"      ." Gforth comes with ABSOLUTELY NO WARRANTY; for details type `license'"
 [ has? os [IF] ]  [ has? os [IF] ]
      cr ." Type `bye' to exit"       cr ." Type `bye' to exit"
 [ [THEN] ] ;  [ [THEN] ] ;
   
 defer bootmessage  defer bootmessage ( -- ) \ gforth
   \G Hook (deferred word) executed right after interpreting the OS
   \G command-line arguments.  Normally prints the Gforth startup
   \G message.
   
   has? file [IF]
 defer process-args  defer process-args
   [THEN]
   
 ' (bootmessage) IS bootmessage  ' gforth IS bootmessage
   
   has? os [IF]
 Defer 'cold ( -- ) \ gforth  tick-cold  Defer 'cold ( -- ) \ gforth  tick-cold
 \ hook (deferred word) for things to do right before interpreting the  \G Hook (deferred word) for things to do right before interpreting the
 \ command-line arguments  \G OS command-line arguments.  Normally does some initializations that
   \G you also want to perform.
 ' noop IS 'cold  ' noop IS 'cold
   [THEN]
 include ../chains.fs  
   
 Variable init8  
   
 : cold ( -- ) \ gforth  : cold ( -- ) \ gforth
   [ has? backtrace [IF] ]
       rp@ backtrace-rp0 !
   [ [THEN] ]
 [ has? file [IF] ]  [ has? file [IF] ]
     pathstring 2@ fpath only-path       os-cold
     init-included-files  
 [ [THEN] ]  [ [THEN] ]
   [ has? os [IF] ]
       set-encoding-fixed-width
     'cold      'cold
     init8 chainperform  [ [THEN] ]
 [ has? file [IF] ]  [ has? file [IF] ]
     process-args      process-args
     loadline off      loadline off
 [ [THEN] ]  [ [THEN] ]
     bootmessage      1 (bye) ;
     quit ;  
   
   has? new-input 0= [IF]
 : clear-tibstack ( -- )  : clear-tibstack ( -- )
 [ has? glocals [IF] ]  [ has? glocals [IF] ]
     lp@ forthstart 7 cells + @ -       lp@ forthstart 7 cells + @ - 
Line 670  Variable init8 Line 1134  Variable init8
     [ has? os [IF] ]      [ has? os [IF] ]
     r0 @ forthstart 6 cells + @ -      r0 @ forthstart 6 cells + @ -
     [ [ELSE] ]      [ [ELSE] ]
     sp@ $10 cells +      sp@ cell+
     [ [THEN] ]      [ [THEN] ]
 [ [THEN] ]  [ [THEN] ]
     dup >tib ! tibstack ! #tib off >in off ;      dup >tib ! tibstack ! #tib off
       input-start-line ;
   [THEN]
   
 : boot ( path **argv argc -- )  : boot ( path n **argv argc -- )
     main-task up!  [ has? no-userspace 0= [IF] ]
       next-task 0= IF  main-task up!
       ELSE
           next-task @ 0= IF
               throw-entry main-task udp @ throw-entry next-task -
               /string >r swap r> move
               next-task dup next-task 2!  normal-dp dpp !
           THEN
       THEN
   [ [THEN] ]
 [ has? os [IF] ]  [ has? os [IF] ]
     stdout TO outfile-id      os-boot
     stdin  TO infile-id  [ [THEN] ]
 \ !! [ [THEN] ]  [ has? rom [IF] ]
 \ !! [ has? file [IF] ]      ram-shadow dup @ dup -1 <> >r u> r> and IF
     argc ! argv ! pathstring 2!          ram-shadow 2@  ELSE
           ram-mirror ram-size  THEN  ram-start swap move
 [ [THEN] ]  [ [THEN] ]
     sp@ sp0 !      sp@ sp0 !
   [ has? peephole [IF] ]
       \ only needed for greedy static superinstruction selection
       \ primtable prepare-peephole-table TO peeptable
   [ [THEN] ]
   [ has? new-input [IF] ]
       current-input off
   [ [THEN] ]
     clear-tibstack      clear-tibstack
       0 0 includefilename 2!
     rp@ rp0 !      rp@ rp0 !
 [ has? floating [IF] ]  [ has? floating [IF] ]
     fp@ fp0 !      fp@ fp0 !
 [ [THEN] ]  [ [THEN] ]
     ['] cold catch DoError cr  
 [ has? os [IF] ]  [ has? os [IF] ]
     bye      handler off
       ['] cold catch dup -&2049 <> if \ broken pipe?
           DoError cr
       endif
   [ [ELSE] ]
       cold
   [ [THEN] ]
   [ has? os [IF] ]
       -1 (bye) \ !! determin exit code from throw code?
 [ [THEN] ]  [ [THEN] ]
 ;  ;
   
Removed from v.1.20  
changed lines
  Added in v.1.195

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