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

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

version 1.7, 1998/10/18 23:16:53 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-2000,2004,2005,2007,2009,2010,2012 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 3
   \ 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, see http://www.gnu.org/licenses/.
   
 \ \ Revision-Log  \ \ Revision-Log
   
 \       put in seperate file                            14sep97jaw   \       put in seperate file                            14sep97jaw 
   
 \ \ 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 23  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 55  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
 \ !! this saving and restoring base is an abomination! - anton  
   
   \ !! 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 ;
   
 : s>number ( addr len -- d )  : sign? ( addr u -- addr1 u1 flag )
     base @ >r  dpl on      over c@ [char] - =  dup >r
     over c@ '- =  dup >r  
     IF      IF
         1 /string          1 /string
     THEN      THEN
     getbase  dpl on  0 0 2swap      r> ;
     BEGIN  
         dup >r >number dup  : ?dnegate ( d1 f -- d2 )
     WHILE      if
         dup r> -          dnegate
     WHILE      then ;
         dup dpl ! over c@ [char] . =  
     WHILE  has? os 0= [IF]
         1 /string  : x@+/string ( addr u -- addr' u' c )
     REPEAT  THEN      over c@ >r 1 /string r> ;
         2drop rdrop dpl off  [THEN]
   
   : s'>unumber? ( addr u -- ud flag )
       \ 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
         2drop rdrop r>          drop 2drop 0. false THEN
         IF  
             dnegate  
         THEN  
     THEN  
     r> base ! ;      r> base ! ;
   
   \ ouch, this is complicated; there must be a simpler way - anton
   : s>number? ( addr u -- d f ) \ gforth
       \G converts string addr u into d, flag indicates success
       sign? >r
       s>unumber?
       0= IF
           rdrop false
       ELSE \ no characters left, all ok
           r> ?dnegate
           true
       THEN ;
   
   : s>number ( addr len -- d )
       \ don't use this, there is no way to tell success
       s>number? drop ;
   
 : snumber? ( c-addr u -- 0 / n -1 / d 0> )  : snumber? ( c-addr u -- 0 / n -1 / d 0> )
     s>number dpl @ 0=      s>number? 0=
     IF      IF
         2drop false  EXIT          2drop false  EXIT
     THEN      THEN
     dpl @ dup 0> 0= IF      dpl @ dup 0< IF
         nip          nip
       ELSE
           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 116  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 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 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 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] ]
     blk @      blk @
     IF      IF
         >in @ c/l / 1+ c/l * >in !          >in @ c/l / 1+ c/l * >in !
         EXIT          EXIT
     THEN      THEN
       [ [THEN] ]
     source >in ! drop ; immediate      source >in ! drop ; immediate
   
 : \G ( -- ) \ gforth backslash  : \G ( compilation 'ccc<newline>' -- ; run-time -- ) \ gforth backslash-gee
       \G Equivalent to @code{\} but used as a tag to annotate definition
       \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 151  end-struct wordlist-map-struct Line 242  end-struct wordlist-map-struct
   
 struct  struct
   cell% field wordlist-map \ pointer to a wordlist-map-struct    cell% field wordlist-map \ pointer to a wordlist-map-struct
   cell% field wordlist-id \ not the same as wid; representation depends on implementation    cell% field wordlist-id \ linked list of words (for WORDS etc.)
   cell% field wordlist-link \ link field to other wordlists    cell% field wordlist-link \ link field to other wordlists
   cell% field wordlist-extend \ points to wordlist extensions (eg hashtables)    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 166  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 @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  \ lookup AValue context ( -- addr ) \ gforth
   Defer context ( -- addr ) \ gforth
   \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 189  $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 200  $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>int ( nt -- xt ) \ gforth  : ((name>))  ( nfa -- cfa )
     \G @var{xt} represents the interpretation semantics of the word      name>string + cfaligned ;
     \G @var{nt}. Produces @code{' compile-only-error} if  
     \G @var{nt} is compile-only.  : (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-to-int
       \G @i{xt} represents the interpretation semantics of the word
       \G @i{nt}. If @i{nt} has no interpretation semantics (i.e. is
       \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 247  $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 ;
   
 const Create ???  0 , 3 c, char ? c, char ? c, char ? c,  [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  \ ??? is used by dovar:, must be created/:dovar
   
 : >head ( cfa -- nt ) \ gforth  to-name  [IFDEF] forthstart
  $21 cell do  \ if we have a forthstart we can define head? with it
    dup i - count $9F and + cfaligned over alias-mask + = if  \ otherwise leave out the head? check
      i - cell - unloop exit  
    then  : one-head? ( addr -- f )
  cell +loop  \G heuristic check whether addr is a name token; may deliver false
  drop ??? ( wouldn't 0 be better? ) ;  \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 )
   \G heuristic check whether addr is a name token; may deliver false
   \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
       \ iterations should catch most false addresses: on the first
       \ iteration, we may get an xt, on the second a code address (or
       \ some code), which is typically not in the dictionary.
       \ we added a third iteration for working with code and ;code words.
       3 0 do
           dup one-head? 0= if
               drop false unloop exit
           endif
           dup @ dup 0= if
               2drop 1 unloop exit
           else
               dup rot forthstart within if
                   drop false unloop exit
               then
           then
       loop
       drop true ;
   
 ' >head ALIAS >name  : >head-noprim ( cfa -- nt ) \ gforth  to-head-noprim
       \ also heuristic
       dup forthstart - max-name-length @
       [ has? float [IF] ] float+ [ [ELSE] ] cell+ [ [THEN] ] cell+ min
       cell max 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 )
               dup i - cell - dup head?
               if
                   nip unloop exit
               then
               drop
           then
           cell +loop
       drop ??? ( wouldn't 0 be better? ) ;
   
 : body> 0 >body - ;  [ELSE]
   
 : (search-wordlist)  ( addr count wid -- nt / false )  : >head-noprim ( cfa -- nt ) \ gforth  to-head-noprim
     dup wordlist-map @ find-method perform ;      $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 -- 0 / xt +-1 ) \ search  [THEN]
     \ xt is the interpretation semantics  
     (search-wordlist) dup if  
         (name>intn)  
     then ;  
   
 : find-name ( c-addr u -- nt/0 ) \ gforth  cell% 2* 0 0 field >body ( xt -- a_addr ) \ core to-body
     \g Find the name @var{c-addr u} in the current search  \G Get the address of the body of the word represented by @i{xt} (the
     \g order. Return its nt, if found, otherwise 0.  \G address of the word's data field).
     lookup @ (search-wordlist) ;  drop drop
   
   cell% -2 * 0 0 field body> ( xt -- a_addr )
       drop drop
   
   has? standardthreading has? compiler and [IF]
   
   ' @ 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 ;
   
   has? prims [IF]
       : flash! ! ;
       : flashc! c! ;
   [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 294  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 for the
       \G definition named by the counted string at @i{c-addr}.  If the
       \G definition is not found, return 0. If the definition is found
       \G return 1 (if the definition has non-default compilation
       \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 )  loadline @ ;  : 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
   blk @  IF  1 blk +!  true  0 >in !  EXIT  THEN      \G Attempt to fill the input buffer from the input source.  When
   tib /line      \G the input source is the user input device, attempt to receive
 [ has? file [IF] ]      \G input into the terminal input device. If successful, make the
   loadfile @ ?dup      \G result the input buffer, set @code{>IN} to 0 and return true;
   IF    read-line throw      \G otherwise return false. When the input source is a block, add 1
   ELSE      \G to the value of @code{BLK} to make the next block the input
 [ [THEN] ]      \G source and current input buffer, and set @code{>IN} to 0;
       sourceline# 0< IF 2drop false EXIT THEN      \G return true if the new value of @code{BLK} is a valid block
       accept true      \G number, false otherwise. When the input source is a text file,
 [ has? file [IF] ]      \G attempt to read the next line from the file. If successful,
   THEN      \G make the result the current input buffer, set @code{>IN} to 0
 [ [THEN] ]      \G and return true; otherwise, return false.  A successful result
   1 loadline +!      \G includes receipt of a line containing 0 characters.
   swap #tib ! 0 >in ! ;      [ has? file [IF] ]
           blk @  IF  1 blk +!  true  EXIT  THEN
           [ [THEN] ]
       tib /line
       [ has? file [IF] ]
           loadfile @ ?dup
           IF    (read-line) throw #fill-bytes !
           ELSE
               [ [THEN] ]
           sourceline# 0< IF 2drop false EXIT THEN
           accept eof @ 0=
           [ has? file [IF] ]
           THEN
           1 loadline +!
           [ [THEN] ]
       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
     blk off loadfile off      \G the Terminal Input Buffer. Set @code{>IN} to zero. OBSOLESCENT:
     tib /line accept #tib ! 0 >in ! ;      \G superceeded by @code{accept}.
       [ has? file [IF] ]
           blk off loadfile off
           [ [THEN] ]
       refill drop ;
   [THEN]
   
 \ save-mem extend-mem  \ save-mem extend-mem
   
Line 394  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>
   sourceline# >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
   tibstack @ >tib ! >in @ >r  >r ;    tibstack @ >tib ! >in @ >r  >r ;
   
 : pop-file   ( throw-code -- throw-code )  : pop-file   ( throw-code -- throw-code )
   r>    r>
   r> >in !  r> #tib !  r> >tib !  r> tibstack !  r> loadline !  >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 blk off loadfile off -1 loadline !      \G Save the current input source specification. Store @code{-1} in
   ['] interpret catch      \G @code{source-id} and @code{0} in @code{blk}. Set @code{>IN} to
   pop-file throw ;      \G @code{0} and make the string @i{c-addr u} the input source
       \G and input buffer. Interpret. When the parse area is empty,
       \G restore the input source specification.
   [ 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) ( -- )
     loadfile off  blk off loadline off refill drop ;      \ exits only through THROW etc.
       BEGIN
 : (quit)  BEGIN  .status cr (query) interpret prompt  AGAIN ;          [ has? ec [IF] ] cr [ [ELSE] ]
           .status ['] cr catch if
               [ has? OS [IF] ] >stderr [ [THEN] ]
               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
     \ print value in decimal representation      \G Display @i{n} as a signed decimal number, followed by a space.
       \ !! not used...
     base @ decimal swap . base ! ;      base @ decimal swap . base ! ;
   
 : hex. ( u -- ) \ gforth  : dec.r ( u n -- ) \ gforth
     \ print value as unsigned hex number      \G Display @i{u} as a unsigned decimal number in a field @i{n}
     '$ emit base @ swap hex u. base ! ;      \G characters wide.
       base @ >r decimal .r r> base ! ;
   
 : typewhite ( addr u -- ) \ gforth  : hex. ( u -- ) \ gforth
     \ like type, but white space is printed instead of the characters      \G Display @i{u} as an unsigned hex number, prefixed with a "$" and
     bounds ?do      \G followed by a space.
         i c@ #tab = if \ check for tab      \ !! not used...
             #tab      [char] $ emit base @ swap hex u. base ! ;
         else  
             bl  : -trailing  ( c_addr u1 -- c_addr u2 ) \ string dash-trailing
         then  \G Adjust the string specified by @i{c-addr, u1} to remove all
         emit  \G trailing spaces. @i{u2} is the length of the modified string.
     loop ;      BEGIN
           dup
       WHILE
           1- 2dup + c@ bl <>
       UNTIL  1+  THEN ;
   
 DEFER DOERROR  DEFER DOERROR
   
 : .error-frame ( addr1 u1 n1 n2 addr2 u2 -- )  has? backtrace [IF]
   cr error-stack @  Defer dobacktrace ( -- )
   IF  ' noop IS dobacktrace
      ." in file included from "  [THEN]
      type ." :" dec.  drop 2drop  
   ELSE  : .error-string ( throw-code -- )
      type ." :" dec.    dup -2 = 
      cr dup 2over type cr drop    IF    "error @ ?dup IF count type  THEN drop
      nip -trailing 1- ( line-start index2 )    ELSE  .error
      0 >r  BEGIN    THEN ;
                   2dup + c@ bl >  WHILE  
                   r> 1+ >r  1- dup 0<  UNTIL  THEN  1+  [IFUNDEF] umin
      ( line-start index1 )  : umin ( u1 u2 -- u )
      typewhite      2dup u>
      r> 1 max 0 ?do \ we want at least one "^", even if the length is 0      if
                   [char] ^ emit          swap
      loop      then
   THEN      drop ;
 ;  [THEN]
   
   Defer mark-start
   Defer mark-end
   
   :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] ]
       outfile-id dup flush-file drop >r        >stderr
       stderr to outfile-id  
   [ [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    dobacktrace
      IF  [ [THEN] ]
         cr count type     normal-dp dpp ! ;
      THEN  
      drop  
   ELSE  
      .error  
   THEN  
   normal-dp dpp !   
   [ has? os [IF] ] r> to outfile-id [ [THEN] ]  
   ;  
   
 ' (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) 1994-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
   
 Defer 'cold   has? os [IF]
 \ hook (deferred word) for things to do right before interpreting the  Defer 'cold ( -- ) \ gforth  tick-cold
 \ command-line arguments  \G Hook (deferred word) for things to do right before interpreting the
   \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 catch ?dup      process-args
     IF      loadline off
       dup >r DoError cr r> negate (bye)  
     THEN  
     argc @ 1 >  
     IF  \ there may be some unfinished line, so let's finish it  
         cr  
     THEN  
 [ [THEN] ]  [ [THEN] ]
     bootmessage      1 (bye) ;
     loadline off quit ;  
   
   has? new-input 0= [IF]
 : clear-tibstack ( -- )  : clear-tibstack ( -- )
 [ has? glocals [IF] ]  [ has? glocals [IF] ]
     lp@ forthstart 7 cells + @ -       lp@ forthstart 7 cells + @ - 
 [ [ELSE] ]  [ [ELSE] ]
     [ has? os [IF] ]      [ has? os [IF] ]
     sp@ $1040 +      r0 @ forthstart 6 cells + @ -
     [ [ELSE] ]      [ [ELSE] ]
     sp@ $40 +      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  
 [ 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.7  
changed lines
  Added in v.1.195

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