[gforth] / gforth / kernel / int.fs  

gforth: gforth/kernel/int.fs

Diff for /gforth/kernel/int.fs between version 1.30 and 1.86

version 1.30, Wed May 5 12:03:30 1999 UTC version 1.86, Fri Jan 10 21:19:59 2003 UTC
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 Free Software Foundation, Inc.
   
 \ This file is part of Gforth.  \ This file is part of Gforth.
   
Line 16 
Line 16 
   
 \ 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, write to the Free Software
 \ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.  \ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA.
   
 \ \ Revision-Log  \ \ Revision-Log
   
Line 24 
Line 24 
   
 \ \ input stream primitives                             23feb93py  \ \ input stream primitives                             23feb93py
   
 : tib ( -- c-addr ) \ core-ext  require ./basics.fs     \ bounds decimal hex ...
     \G @var{c-addr} is the address of the Terminal Input Buffer.  require ./io.fs         \ type ...
   require ./nio.fs        \ . <# ...
   require ./errore.fs     \ .error ...
   require kernel/version.fs       \ version-string
   require ./../chains.fs
   
   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.      \G OBSOLESCENT: @code{source} superceeds the function of this word.
     >tib @ ;      >tib @ ;
   
 Defer source ( -- c-addr u ) \ core  Defer source ( -- c-addr u ) \ core
 \ used by dodefer:, must be defer  \ used by dodefer:, must be defer
 \G @var{c-addr} is the address of the input buffer and @var{u} is the  \G @i{c-addr} is the address of the input buffer and @i{u} is the
 \G number of characters in it.  \G number of characters in it.
   
 : (source) ( -- c-addr u )  : (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 47 
Line 56 
 \ word parse                                           23feb93py  \ word parse                                           23feb93py
   
 : sword  ( char -- addr len ) \ gforth s-word  : sword  ( char -- addr len ) \ gforth s-word
   \G Parses like @code{word}, but the output is like @code{parse} output      \G Parses like @code{word}, but the output is like @code{parse} output.
       \G @xref{core-idef}.
   \ this word was called PARSE-WORD until 0.3.0, but Open Firmware and    \ this word was called PARSE-WORD until 0.3.0, but Open Firmware and
   \ dpANS6 A.6.2.2008 have a word with that name that behaves    \ dpANS6 A.6.2.2008 have a word with that name that behaves
   \ differently (like NAME).    \ differently (like NAME).
Line 56 
Line 66 
   2dup + r> - 1+ r> min >in ! ;    2dup + r> - 1+ r> min >in ! ;
   
 : word   ( char "<chars>ccc<char>-- c-addr ) \ core  : word   ( char "<chars>ccc<char>-- c-addr ) \ core
     \G Skip leading delimiters. Parse @var{ccc}, delimited by      \G Skip leading delimiters. Parse @i{ccc}, delimited by
     \G @var{char}, in the parse area. @var{c-addr} is the addres of a      \G @i{char}, in the parse area. @i{c-addr} is the address of a
     \G transient region containing the parsed string in      \G transient region containing the parsed string in
     \G counted-strinng format. If the parse area was empty or      \G counted-string format. If the parse area was empty or
     \G contained no characters other than delimiters, the resulting      \G contained no characters other than delimiters, the resulting
     \G string has zero length. A program may replace characters within      \G string has zero length. A program may replace characters within
     \G the counted string. OBSOLESCENT: the counted string has a      \G the counted string. OBSOLESCENT: the counted string has a
Line 67 
Line 77 
     sword here place  bl here count + c!  here ;      sword here place  bl here count + c!  here ;
   
 : parse    ( char "ccc<char>" -- c-addr u ) \ core-ext  : parse    ( char "ccc<char>" -- c-addr u ) \ core-ext
     \G Parse @var{ccc}, delimited by @var{char}, in the parse  \G Parse @i{ccc}, delimited by @i{char}, in the parse
     \G area. @var{c-addr u} specifies the parsed string within the  \G area. @i{c-addr u} specifies the parsed string within the
     \G parse area. If the parse area was empty, @var{u} is 0.  \G parse area. If the parse area was empty, @i{u} is 0.
     >r  source  >in @ over min /string  over  swap r>  scan >r      >r  source  >in @ over min /string  over  swap r>  scan >r
   over - dup r> IF 1+ THEN  >in +! ;    over - dup r> IF 1+ THEN  >in +! ;
   
Line 77 
Line 87 
   
 [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)
     2dup + r> - 1+ r> min >in ! ;      2dup + r> - 1+ r> min >in ! ;
 \    name count ;  \    name count ;
Line 87 
Line 97 
     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
   
Line 107 
Line 117 
     THEN ;      THEN ;
   
 : sign? ( addr u -- addr u flag )  : sign? ( addr u -- addr u flag )
     over c@ '- =  dup >r      over c@ [char] - =  dup >r
     IF      IF
         1 /string          1 /string
     THEN      THEN
Line 182 
Line 192 
     \G by cross.fs which doesn't have the same functionalty as makedoc.fs      \G by cross.fs which doesn't have the same functionalty as makedoc.fs
     [char] ) parse 2drop ; immediate      [char] ) parse 2drop ; immediate
   
 : \ ( -- ) \ thisone- 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 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      \G by cross.fs which doesn't have the same functionalty as makedoc.fs
Line 195 
Line 205 
     [ [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
Line 220 
Line 230 
 end-struct wordlist-struct  end-struct wordlist-struct
   
 : f83find      ( addr len wordlist -- nt / false )  : f83find      ( addr len wordlist -- nt / false )
     wordlist-id @ (f83find) ;      wordlist-id @ (listlfind) ;
   
 : initvoc               ( wid -- )  : initvoc               ( wid -- )
   dup wordlist-map @ hash-method perform ;    dup wordlist-map @ hash-method perform ;
Line 235 
Line 245 
 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 !
   
 \ \ 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  
   $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]
   $1fffffff constant lcount-mask
   1 bits/char 3 - lshift 1 -
   -1 cells allot  bigendian [IF]   c, -1 1 cells 1- times
                             [ELSE] -1 1 cells 1- times c, [THEN]
   
 \ higher level parts of find  \ higher level parts of find
   
Line 255 
Line 283 
     \ true becomes 1, false -1      \ true becomes 1, false -1
     0= 2* 1+ ;      0= 2* 1+ ;
   
 : compile-only-error ( ... -- )  : ticking-compile-only-error ( ... -- )
     -&14 throw ;      -&2048 throw ;
   
 : (cfa>int) ( cfa -- xt )  : (cfa>int) ( cfa -- xt )
 [ has? compiler [IF] ]  [ has? compiler [IF] ]
Line 266 
Line 294 
     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
     if      if
         drop ['] compile-only-error          drop ['] ticking-compile-only-error
     else      else
         (cfa>int)          (cfa>int)
     then ;      then ;
   
 : name>string ( nt -- addr count ) \ gforth     head-to-string  : name>string ( nt -- addr count ) \ gforth     head-to-string
     \g @var{addr count} is the name of the word represented by @var{nt}.      \g @i{addr count} is the name of the word represented by @i{nt}.
     cell+ count $1F and ;      cell+ dup cell+ swap @ 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+ @ dup alias-mask and 0=
     IF      IF
         swap @ swap          swap @ swap
     THEN ;      THEN ;
   
 : name>int ( nt -- xt ) \ gforth  : name>int ( nt -- xt ) \ gforth
     \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
     \G Like @code{name>int}, but throws an error if @code{compile-only}.      \G Like @code{name>int}, but perform @code{-2048 throw} if @i{nt}
       \G has no interpretation semantics.
     (name>x) restrict-mask and      (name>x) restrict-mask and
     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 317 
Line 347 
     ;      ;
   
 : (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 flag-sign ;
   
 const Create ???  0 , 3 c, char ? c, char ? c, char ? c,  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
   
 [IFDEF] forthstart  [IFDEF] forthstart
Line 329 
Line 359 
   
 : 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.
       3 0 do
           dup dup aligned <> if \ protect @ against unaligned accesses
               drop false unloop exit
           then
         dup @ dup          dup @ dup
         if ( addr addr1 )          if ( addr addr1 )
             dup rot forthstart within              dup rot forthstart within
Line 342 
Line 377 
                 drop false unloop exit                  drop false unloop exit
             then ( addr1 )              then ( addr1 )
         else \ 0 in the link field, no further checks          else \ 0 in the link field, no further checks
             2drop true unloop exit              2drop 1 unloop exit \ this is very unsure, so return 1
         then          then
     loop      loop
     \ in dubio pro:      \ in dubio pro:
     drop true ;      drop true ;
   
 : >head ( cfa -- nt ) \ gforth  to-head  : >head-noprim ( cfa -- nt ) \ gforth  to-head-noprim
     $21 cell do ( cfa )      \ also heuristic; finds only names with up to 32 chars
         dup i - count $9F and + cfaligned over alias-mask + =      $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 )          if ( cfa )
             dup i - cell - dup head?              dup i - cell - dup head?
             if              if
Line 363 
Line 404 
   
 [ELSE]  [ELSE]
   
 : >head ( cfa -- nt ) \ gforth  to-head  : >head-noprim ( cfa -- nt ) \ gforth  to-head-noprim
     $21 cell do ( cfa )      $25 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 ) i - cell - unloop exit          if ( cfa ) i - cell - unloop exit
         then          then
         cell +loop          cell +loop
Line 373 
Line 419 
   
 [THEN]  [THEN]
   
 ' >head ALIAS >name  cell% 2* 0 0 field >body ( xt -- a_addr ) \ core
   \G Get the address of the body of the word represented by @i{xt} (the
   \G address of the word's data field).
   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 ;
   
 : body> 0 >body - ;  ' ! alias code-address! ( c_addr xt -- ) \ gforth
   \G Create a code field with code address @i{c-addr} at @i{xt}.
   
   : 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>}.
       dodoes: over ! cell+ ! ;
   
   ' drop alias does-handler! ( a_addr -- ) \ gforth
   \G Create a @code{DOES>}-handler at address @i{a-addr}. Normally,
   \G @i{a-addr} points just behind a @code{DOES>}.
   
   2 cells constant /does-handler ( -- n ) \ gforth
   \G The size of a @code{DOES>}-handler (includes possible padding).
   
   [THEN]
   
 : (search-wordlist)  ( addr count wid -- nt / false )  : (search-wordlist)  ( addr count wid -- nt | false )
     dup wordlist-map @ find-method perform ;      dup wordlist-map @ find-method perform ;
   
 : search-wordlist ( c-addr count wid -- 0 / xt +-1 ) \ search  : search-wordlist ( c-addr count wid -- 0 | xt +-1 ) \ search
     \G Search the word list identified by @var{wid}      \G Search the word list identified by @i{wid} for the definition
     \G for the definition named by the string at @var{c-addr count}.      \G named by the string at @i{c-addr count}.  If the definition is
     \G If the definition is not found, return 0. If the definition      \G not found, return 0. If the definition is found return 1 (if
     \G is found return 1 (if the definition is immediate) or -1      \G the definition is immediate) or -1 (if the definition is not
     \G (if the definition is not immediate) together with the @var{xt}.      \G immediate) together with the @i{xt}.  In Gforth, the @i{xt}
     \G The @var{xt} returned represents the interpretation semantics.      \G returned represents the interpretation semantics.  ANS Forth
       \G does not specify clearly what @i{xt} represents.
     (search-wordlist) dup if      (search-wordlist) dup if
         (name>intn)          (name>intn)
     then ;      then ;
   
 : find-name ( c-addr u -- nt/0 ) \ gforth  : find-name ( c-addr u -- nt | 0 ) \ gforth
     \g Find the name @var{c-addr u} in the current search      \g Find the name @i{c-addr u} in the current search
     \g order. Return its nt, if found, otherwise 0.      \g order. Return its @i{nt}, if found, otherwise 0.
     lookup @ (search-wordlist) ;      lookup @ (search-wordlist) ;
   
 : sfind ( c-addr u -- 0 / xt +-1  ) \ gforth-obsolete  : sfind ( c-addr u -- 0 / xt +-1  ) \ gforth-obsolete
Line 407 
Line 490 
         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 @var{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 @var{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 dup 0= -&16 and throw \ test for length 0      name name-too-short?
     find-name dup 0=      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 parser ( c-addr u -- )
 Defer name ( -- c-addr count ) \ gforth  Defer parse-word ( -- c-addr count ) \ gforth
 \ get the next word from the input buffer  \G Get the next word from the input buffer
 ' (name) IS name  ' (name) IS parse-word
   
   ' parse-word alias name ( -- c-addr u ) \ gforth-obsolete
   \G old name for @code{parse-word}
   
 Defer compiler-notfound ( c-addr count -- )  Defer compiler-notfound ( c-addr count -- )
 Defer interpreter-notfound ( c-addr count -- )  Defer interpreter-notfound ( c-addr count -- )
   
 : no.extensions  ( addr u -- )  : no.extensions  ( addr u -- )
     2drop -&13 bounce ;      2drop -&13 throw ;
 ' no.extensions IS compiler-notfound  ' no.extensions IS compiler-notfound
 ' no.extensions IS interpreter-notfound  ' no.extensions IS interpreter-notfound
   
 : interpret ( ?? -- ?? ) \ gforth  : interpret1 ( ... -- ... )
     \ interpret/compile the (rest of the) input buffer  [ has? backtrace [IF] ]
     rp@ backtrace-rp0 !      rp@ backtrace-rp0 !
   [ [THEN] ]
     BEGIN      BEGIN
         ?stack name dup          ?stack name dup
     WHILE      WHILE
Line 459 
Line 565 
     REPEAT      REPEAT
     2drop ;      2drop ;
   
   : interpret ( ?? -- ?? ) \ gforth
       \ interpret/compile the (rest of the) input buffer
   [ has? backtrace [IF] ]
       backtrace-rp0 @ >r
   [ [THEN] ]
       ['] interpret1 catch
   [ has? backtrace [IF] ]
       r> backtrace-rp0 !
       [ [THEN] ]
       throw ;
   
 \ interpreter                                   30apr92py  \ interpreter                                   30apr92py
   
 \ not the most efficient implementations of interpreter and compiler  \ not the most efficient implementations of interpreter and compiler
 | : interpreter ( c-addr u -- )  : interpreter ( c-addr u -- )
     2dup find-name dup      2dup find-name dup
     if      if
         nip nip name>int execute          nip nip name>int execute
Line 482 
Line 599 
   
 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]
 : 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 Attempt to fill the input buffer from the input source.  When
     \G the input source is the user input device, attempt to receive      \G the input source is the user input device, attempt to receive
Line 504 
Line 627 
     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
Line 522 
Line 645 
     [ 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 533 
Line 657 
     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
Line 542 
Line 677 
   
 \ 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 553 
Line 688 
   r> >in !  r> #tib !  r> >tib !  r> tibstack !  >r ;    r> >in !  r> #tib !  r> >tib !  r> tibstack !  >r ;
 [THEN]  [THEN]
   
   has? new-input 0= [IF]
 : evaluate ( c-addr u -- ) \ core,block  : evaluate ( c-addr u -- ) \ core,block
     \G Save the current input source specification. Store -1 in      \G Save the current input source specification. Store @code{-1} in
     \G @code{source-id} and 0 in @code{blk}. Set @code{>IN} to 0 and      \G @code{source-id} and @code{0} in @code{blk}. Set @code{>IN} to
     \G make the string @var{c-addr u} the input source and input      \G @code{0} and make the string @i{c-addr u} the input source
     \G buffer. Interpret. When the parse area is empty, restore the      \G and input buffer. Interpret. When the parse area is empty,
     \G input source specification.      \G restore the input source specification.
   [ has? file [IF] ]
       loadfilename# @ >r
       1 loadfilename# ! \ "*evaluated string*"
   [ [THEN] ]
     push-file  #tib ! >tib !      push-file  #tib ! >tib !
     >in off      >in off
     [ has? file [IF] ]      [ has? file [IF] ]
         blk off loadfile off -1 loadline !          blk off loadfile off -1 loadline !
         [ [THEN] ]          [ [THEN] ]
     ['] interpret catch      ['] interpret catch
     pop-file throw ;      pop-file
   [ has? file [IF] ]
       r> loadfilename# !
   [ [THEN] ]
       throw ;
   [THEN]
   
 \ \ Quit                                                13feb93py  \ \ Quit                                                13feb93py
   
Line 575 
Line 720 
   
 : 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  \    sp0 @ cell - handler @ &12 + ! \ !! kludge: fix the stack pointer
         [ [THEN] ]      \ stored in the system's CATCH frame, so the stack depth will be 0
     refill drop ;      \ after the next THROW it catches (it may be off due to BOUNCEs or
       \ because process-args left something on the stack)
 : (quit)  BEGIN  .status cr (query) interpret prompt  AGAIN ;      BEGIN
           .status cr query interpret prompt
       AGAIN ;
   
 ' (quit) IS 'quit  ' (quit) IS 'quit
   
Line 589 
Line 736 
   
 8 Constant max-errors  8 Constant max-errors
 Variable error-stack  0 error-stack !  Variable error-stack  0 error-stack !
 max-errors 6 * cells allot  max-errors has? file [IF] 6 [ELSE] 4 [THEN] * cells allot
 \ format of one cell:  \ format of one cell:
 \ source ( addr u )  \ source ( addr u )
 \ >in  \ >in
 \ line-number  \ line-number
 \ Loadfilename ( addr u )  \ Loadfilename ( addr u )
   
   : error> ( -- addr u >in line# [addr u] )
       -1 error-stack +!
       error-stack dup @
       [ has? file [IF] 6 [ELSE] 4 [THEN] ] Literal * cells + cell+
       [ has? file [IF] 6 [ELSE] 4 [THEN] ] Literal cells bounds DO
           I @
           cell +LOOP ;
   : >error ( addr u >in line# [addr u] -- )
       error-stack dup @ dup 1+
       max-errors 1- min error-stack !
       [ has? file [IF] 6 [ELSE] 4 [THEN] ] Literal * cells + cell+
       [ has? file [IF] 6 [ELSE] 4 [THEN] 1- ] Literal cells bounds swap DO
           I !
           -1 cells +LOOP ;
   
 : dec. ( n -- ) \ gforth  : dec. ( n -- ) \ gforth
     \G Display @var{n} as a signed decimal number, followed by a space.      \G Display @i{n} as a signed decimal number, followed by a space.
     \G !! not used...      \ !! not used...
     base @ decimal swap . base ! ;      base @ decimal swap . base ! ;
   
 : dec.r ( u -- ) \ gforth  : dec.r ( u -- ) \ gforth
     \G Display @var{u} as a unsigned decimal number      \G Display @i{u} as a unsigned decimal number
     base @ decimal swap 0 .r base ! ;      base @ decimal swap 0 .r base ! ;
   
 : hex. ( u -- ) \ gforth  : hex. ( u -- ) \ gforth
     \G Display @var{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.
     \G !! not used...      \ !! not used...
     '$ emit base @ swap hex u. base ! ;      [char] $ emit base @ swap hex u. base ! ;
   
 : typewhite ( addr u -- ) \ gforth  : typewhite ( addr u -- ) \ gforth
     \ like type, but white space is printed instead of the characters      \G Like type, but white space is printed instead of the characters.
     bounds ?do      bounds ?do
         i c@ #tab = if \ check for tab          i c@ #tab = if \ check for tab
             #tab              #tab
Line 623 
Line 785 
     loop ;      loop ;
   
 DEFER DOERROR  DEFER DOERROR
   
   has? backtrace [IF]
 Defer dobacktrace ( -- )  Defer dobacktrace ( -- )
 ' noop IS dobacktrace  ' noop IS dobacktrace
   [THEN]
   
 : .error-string ( throw-code -- )  : .error-string ( throw-code -- )
   dup -2 =    dup -2 =
Line 632 
Line 797 
   ELSE  .error    ELSE  .error
   THEN ;    THEN ;
   
 : .error-frame ( throwcode addr1 u1 n1 n2 addr2 u2 -- throwcode )  : .error-frame ( throwcode addr1 u1 n1 n2 [addr2 u2] -- throwcode )
 \ addr2 u2:     filename of included file  \ addr2 u2:     filename of included file - optional
 \ n2:           line number  \ n2:           line number
 \ n1:           error position in input line  \ n1:           error position in input line
 \ addr1 u1:     input line  \ addr1 u1:     input line
   
   cr error-stack @    cr error-stack @
   IF    IF
   [ has? file [IF] ]
      ." in file included from "       ." in file included from "
      type ." :" dec.r  drop 2drop      type ." :"
   [ [THEN] ]
       dec.r  drop 2drop
   ELSE    ELSE
      type ." :" dec.r ." : " 3 pick .error-string cr  [ has? file [IF] ]
      dup 2over type cr drop        type ." :"
   [ [THEN] ]
         dup >r dec.r ." : " 3 pick .error-string
         r> IF \ if line# non-zero, there is a line
             cr dup 2over type cr drop
      nip -trailing 1- ( line-start index2 )       nip -trailing 1- ( line-start index2 )
      0 >r  BEGIN       0 >r  BEGIN
                   2dup + c@ bl >  WHILE                    2dup + c@ bl >  WHILE
Line 654 
Line 825 
      r> 1 max 0 ?do \ we want at least one "^", even if the length is 0       r> 1 max 0 ?do \ we want at least one "^", even if the length is 0
                   [char] ^ emit                    [char] ^ emit
      loop       loop
         ELSE
             2drop drop
         THEN
   THEN ;    THEN ;
   
 : (DoError) ( throw-code -- )  : (DoError) ( throw-code -- )
   [ has? os [IF] ]    [ has? os [IF] ]
       >stderr        >stderr
   [ [THEN] ]    [ [THEN] ]
   sourceline# IF    source >in @ sourceline# [ has? file [IF] ]
       source >in @ sourceline# 0 0 .error-frame        sourcefilename
   THEN    [ [THEN] ] .error-frame
   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
   drop dobacktrace    drop
   [ has? backtrace [IF] ]
     dobacktrace
   [ [THEN] ]
   normal-dp dpp ! ;    normal-dp dpp ! ;
   
 ' (DoError) IS DoError  ' (DoError) IS DoError
Line 680 
Line 853 
     \G Empty the return stack, make the user input device      \G Empty the return stack, make the user input device
     \G the input source, enter interpret state and start      \G the input source, enter interpret state and start
     \G the text interpreter.      \G the text interpreter.
     rp0 @ rp! handler off clear-tibstack >tib @ >r      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] ]
         ['] 'quit CATCH dup          ['] 'quit CATCH dup
     WHILE      WHILE
         <# \ reset hold area, or we may get another error          <# \ reset hold area, or we may get another error
         DoError r@ >tib ! r@ tibstack !          DoError
           [ 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] ] ;
   
 \ \ Cold Boot                                           13feb93py  \ \ Cold Boot                                           13feb93py
   
 : (bootmessage)  : (bootmessage)
     ." GForth " version-string type      ." GForth " version-string type
     ." , Copyright (C) 1998 Free Software Foundation, Inc." cr      ." , Copyright (C) 1995-2000 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"
Line 712 
Line 891 
 \ command-line arguments  \ command-line arguments
 ' noop IS 'cold  ' noop IS 'cold
   
 include ./../chains.fs  
   
 Variable init8  AVariable init8 NIL 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] ]
     'cold      'cold
     init8 chainperform      init8 chainperform
 [ has? file [IF] ]  [ has? file [IF] ]
       loadfilename# off
     process-args      process-args
     loadline off      loadline off
 [ [THEN] ]  [ [THEN] ]
     bootmessage      bootmessage
     quit ;      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 741 
Line 923 
     [ [THEN] ]      [ [THEN] ]
 [ [THEN] ]  [ [THEN] ]
     dup >tib ! tibstack ! #tib off >in off ;      dup >tib ! tibstack ! #tib off >in off ;
   [THEN]
   
 : boot ( path **argv argc -- )  : boot ( path n **argv argc -- )
     main-task up!      main-task up!
 [ has? os [IF] ]  [ has? os [IF] ]
     stdout TO outfile-id      os-boot
     stdin  TO infile-id  
 \ !! [ [THEN] ]  
 \ !! [ has? file [IF] ]  
     argc ! argv ! pathstring 2!  
 [ [THEN] ]  [ [THEN] ]
     sp@ sp0 !      sp@ sp0 !
   [ has? peephole [IF] ]
       primtable prepare-peephole-table TO peeptable
   [ [THEN] ]
   [ has? new-input [IF] ]
       current-input off
   [ [THEN] ]
     clear-tibstack      clear-tibstack
     rp@ rp0 !      rp@ rp0 !
 [ has? floating [IF] ]  [ has? floating [IF] ]
     fp@ fp0 !      fp@ fp0 !
 [ [THEN] ]  [ [THEN] ]
       handler off
     ['] cold catch DoError cr      ['] cold catch DoError cr
 [ has? os [IF] ]  [ has? os [IF] ]
     bye      1 (bye) \ !! determin exit code from throw code?
 [ [THEN] ]  [ [THEN] ]
 ;  ;
   

Generate output suitable for use with a patch program
Legend:
Removed from v.1.30  
changed lines
  Added in v.1.86
CVS Admin

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help