[gforth] / gforth / kernel / int.fs  

gforth: gforth/kernel/int.fs

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

version 1.86, Fri Jan 10 21:19:59 2003 UTC version 1.183, Mon Nov 14 00:15:27 2011 UTC
Line 1 
Line 1 
 \ definitions needed for interpreter only  \ definitions needed for interpreter only
   
 \ Copyright (C) 1995-2000 Free Software Foundation, Inc.  \ Copyright (C) 1995-2000,2004,2005,2007,2009,2010 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., 59 Temple Place, Suite 330, Boston, MA 02111, USA.  
   
 \ \ Revision-Log  \ \ Revision-Log
   
Line 29 
Line 28 
 require ./nio.fs        \ . <# ...  require ./nio.fs        \ . <# ...
 require ./errore.fs     \ .error ...  require ./errore.fs     \ .error ...
 require kernel/version.fs       \ version-string  require kernel/version.fs       \ version-string
 require ./../chains.fs  
   
 has? new-input 0= [IF]  has? new-input 0= [IF]
 : tib ( -- c-addr ) \ core-ext t-i-b  : tib ( -- c-addr ) \ core-ext t-i-b
Line 53 
Line 51 
 \ (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 s-word  
     \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  
   \ dpANS6 A.6.2.2008 have a word with that name that behaves  
   \ differently (like NAME).  
   source 2dup >r >r >in @ over min /string  
   rot dup bl = IF  drop (parse-white)  ELSE  (word)  THEN  
   2dup + r> - 1+ r> min >in ! ;  
   
 : word   ( char "<chars>ccc<char>-- c-addr ) \ core  
     \G Skip leading delimiters. Parse @i{ccc}, delimited by  
     \G @i{char}, in the parse area. @i{c-addr} is the address of a  
     \G transient region containing the parsed string in  
     \G counted-string format. If the parse area was empty or  
     \G contained no characters other than delimiters, the resulting  
     \G string has zero length. A program may replace characters within  
     \G the counted string. OBSOLESCENT: the counted string has a  
     \G trailing space that is not included in its length.  
     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 @i{ccc}, delimited by @i{char}, in the parse  \G Parse @i{ccc}, delimited by @i{char}, in the parse
 \G area. @i{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, @i{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 ( c-addr1 u1 )
     over - dup r> IF 1+ THEN  >in +! ;      over  swap r>  scan >r
       over - dup r> IF 1+ THEN  >in +!
   [ has? new-input [IF] ]
       2dup input-lexeme!
   [ [THEN] ] ;
   
 \ name                                                 13feb93py  \ name                                                 13feb93py
   
Line 89 
Line 70 
   
 : (name) ( -- c-addr count ) \ gforth  : (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 101 
Line 85 
   
 \ \ 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@ [char] - =  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 )
     base @ >r  dpl on  getbase      if
     0. 2swap          dnegate
       then ;
   
   has? os 0= [IF]
   : x@+/string ( addr u -- addr' u' c )
       over c@ >r 1 /string r> ;
   [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 )      BEGIN ( d addr len )
         dup >r >number dup          dup >r >number dup
     WHILE \ there are characters left      WHILE \ there are characters left
Line 135 
Line 147 
     WHILE \ the current char is '.'      WHILE \ the current char is '.'
         1 /string          1 /string
     REPEAT  THEN \ there are unparseable characters left      REPEAT  THEN \ there are unparseable characters left
         2drop false              2drop rdrop false
     ELSE      ELSE
         rdrop 2drop true              rdrop 2drop r> ?dnegate true
     THEN      THEN
       ELSE
           drop 2drop 0. false THEN
     r> base ! ;      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
     sign? >r      sign? >r
     s>unumber?      s>unumber?
     0= IF      0= IF
         rdrop 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 ;
   
Line 171 
Line 182 
         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 179 
Line 190 
     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 ;
Line 210 
Line 221 
     \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 229 
Line 247 
   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 )
       wordlist-id @ (f83find) ;
   [ELSE]
 : f83find      ( addr len wordlist -- nt / false )  : f83find      ( addr len wordlist -- nt / false )
     wordlist-id @ (listlfind) ;      wordlist-id @ (listlfind) ;
   [THEN]
   
 : initvoc               ( wid -- )  : initvoc               ( wid -- )
   dup wordlist-map @ hash-method perform ;    dup wordlist-map @ hash-method perform ;
Line 239 
Line 262 
 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 !
Line 255 
Line 278 
 ' lookup is context  ' 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
   
 \ The constants are defined as 32 bits, but then erased  \ The constants are defined as 32 bits, but then erased
 \ and overwritten by the right ones  \ and overwritten by the right ones
   
   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  $80000000 constant alias-mask
 1 bits/char 1 - lshift  1 bits/char 1 - lshift
 -1 cells allot  bigendian [IF]   c, 0 1 cells 1- times  -1 cells allot  bigendian [IF]   c, 0 1 cells 1- times
Line 272 
Line 327 
 1 bits/char 3 - lshift  1 bits/char 3 - lshift
 -1 cells allot  bigendian [IF]   c, 0 1 cells 1- times  -1 cells allot  bigendian [IF]   c, 0 1 cells 1- times
                           [ELSE] 0 1 cells 1- times c, [THEN]                            [ELSE] 0 1 cells 1- times c, [THEN]
 $1fffffff constant lcount-mask  $10000000 constant prelude-mask
 1 bits/char 3 - lshift 1 -  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  -1 cells allot  bigendian [IF]   c, -1 1 cells 1- times
                           [ELSE] -1 1 cells 1- times c, [THEN]                            [ELSE] -1 1 cells 1- times c, [THEN]
   [THEN]
   
 \ higher level parts of find  \ higher level parts of find
   
Line 286 
Line 346 
 : ticking-compile-only-error ( ... -- )  : ticking-compile-only-error ( ... -- )
     -&2048 throw ;      -&2048 throw ;
   
   : compile-only-error ( ... -- )
       -&14 throw ;
   
 : (cfa>int) ( cfa -- xt )  : (cfa>int) ( cfa -- xt )
 [ has? compiler [IF] ]  [ has? compiler [IF] ]
     dup interpret/compile?      dup interpret/compile?
Line 296 
Line 359 
   
 : (x>int) ( cfa w -- 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 ['] ticking-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]
   : name>string ( nt -- addr count ) \ gforth     name-to-string
       \g @i{addr count} is the name of the word represented by @i{nt}.
       cell+ count 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+ c@ dup alias-mask and 0=
       IF
           swap @ swap
       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}.      \g @i{addr count} is the name of the word represented by @i{nt}.
     cell+ dup cell+ swap @ lcount-mask and ;      cell+ dup cell+ swap @ lcount-mask and ;
   
Line 317 
Line 396 
     IF      IF
         swap @ swap          swap @ swap
     THEN ;      THEN ;
   [THEN]
   
 : name>int ( nt -- xt ) \ gforth  : name>int ( nt -- xt ) \ gforth name-to-int
     \G @i{xt} represents the interpretation semantics of the word      \G @i{xt} represents the interpretation semantics of the word
     \G @i{nt}. If @i{nt} has no interpretation semantics (i.e. is      \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{compile-only}), @i{xt} is the execution token for
     \G @code{ticking-compile-only-error}, which performs @code{-2048 throw}.      \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 @code{name>int}, but perform @code{-2048 throw} if @i{nt}      \G Like @code{name>int}, but perform @code{-2048 throw} if @i{nt}
     \G has no interpretation semantics.      \G has no interpretation semantics.
     (name>x) restrict-mask and      (name>x) restrict-mask and [ has? rom [IF] ] 0= [ [THEN] ]
     if      if
         ticking-compile-only-error \ does not return          ticking-compile-only-error \ does not return
     then      then
Line 343 
Line 423 
         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) ( w 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,  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
Line 359 
Line 448 
   
 : 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; returns 1 for  \G positives; addr must be a valid address
 \G particularly unsafe positives      dup dup aligned <>
     \ we follow the link fields and check for plausibility; two      if
     \ iterations should catch most false addresses: on the first          drop false exit \ heads are aligned
     \ 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 dup aligned <> if \ protect @ against unaligned accesses  
             drop false unloop exit  
         then          then
         dup @ dup      name>string dup $20 $1 within if
         if ( addr addr1 )          2drop false exit \ realistically the name is short
             dup rot forthstart within  
             if \ addr1 is outside forthstart..addr, not a head  
                 drop false unloop exit  
             then ( addr1 )  
         else \ 0 in the link field, no further checks  
             2drop 1 unloop exit \ this is very unsure, so return 1  
         then          then
     loop      + cfaligned @ here forthstart within ; \ and the cfa is outside
     \ in dubio pro:  
     drop true ;  
   
 : >head-noprim ( cfa -- nt ) \ gforth  to-head-noprim  : >head-noprim ( cfa -- nt ) \ gforth  to-head-noprim
     \ also heuristic; finds only names with up to 32 chars      \ also heuristic
     $25 cell do ( cfa )      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          dup i - dup @ [ alias-mask lcount-mask or ] literal
         [ 1 bits/char 3 - lshift 1 - 1 bits/char 1 - lshift or          [ 1 bits/char 3 - lshift 1 - 1 bits/char 1 - lshift or
         -1 cells allot bigendian [IF]   c, -1 1 cells 1- times          -1 cells allot bigendian [IF]   c, -1 1 cells 1- times
Line 419 
Line 496 
   
 [THEN]  [THEN]
   
 cell% 2* 0 0 field >body ( xt -- a_addr ) \ core  cell% 2* 0 0 field >body ( xt -- a_addr ) \ core to-body
 \G Get the address of the body of the word represented by @i{xt} (the  \G Get the address of the body of the word represented by @i{xt} (the
 \G address of the word's data field).  \G address of the word's data field).
 drop drop  drop drop
Line 442 
Line 519 
         drop 0          drop 0
     endif ;      endif ;
   
 ' ! alias code-address! ( c_addr xt -- ) \ gforth  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}.  \G Create a code field with code address @i{c-addr} at @i{xt}.
   
 : does-code! ( a_addr xt -- ) \ gforth  : 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 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>}.  \G @i{a-addr} is the start of the Forth code after @code{DOES>}.
     dodoes: over ! cell+ ! ;      [ has? flash [IF] ]
       dodoes: over flash! cell+ flash!
 ' drop alias does-handler! ( a_addr -- ) \ gforth      [ [ELSE] ]
 \G Create a @code{DOES>}-handler at address @i{a-addr}. Normally,      dodoes: any-code!
 \G @i{a-addr} points just behind a @code{DOES>}.      [ [THEN] ] ;
   
 2 cells constant /does-handler ( -- n ) \ gforth  2 cells constant /does-handler ( -- n ) \ gforth
 \G The size of a @code{DOES>}-handler (includes possible padding).  \G The size of a @code{DOES>}-handler (includes possible padding).
   
 [THEN]  [THEN]
   
 : (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) ;  
   
 : sfind ( c-addr u -- 0 / xt +-1  ) \ gforth-obsolete  : sfind ( c-addr u -- 0 / xt +-1  ) \ gforth-obsolete
     find-name dup      find-name dup
     if ( nt )      if ( nt )
Line 515 
Line 583 
 \ ticks in interpreter  \ ticks in interpreter
   
 : (') ( "name" -- nt ) \ gforth  : (') ( "name" -- nt ) \ gforth
     name name-too-short?      parse-name name-too-short?
     find-name dup 0=      find-name dup 0=
     IF      IF
         drop -&13 throw          drop -&13 throw
Line 538 
Line 606 
   
 \ interpret                                            10mar92py  \ interpret                                            10mar92py
   
 Defer parser ( c-addr u -- )  Defer parser1 ( c-addr u -- ... xt)
 Defer parse-word ( -- c-addr count ) \ gforth  \ "... xt" is the action to be performed by the text-interpretation of c-addr u
   
   : 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  \G Get the next word from the input buffer
 ' (name) IS parse-word  ' (name) IS parse-name
   
 ' parse-word alias name ( -- c-addr u ) \ gforth-obsolete  ' parse-name alias parse-word ( -- c-addr u ) \ gforth-obsolete
 \G old name for @code{parse-word}  \G old name for @code{parse-name}
   
 Defer compiler-notfound ( c-addr count -- )  ' parse-name alias name ( -- c-addr u ) \ gforth-obsolete
 Defer interpreter-notfound ( c-addr count -- )  \G old name for @code{parse-name}
   
 : no.extensions  ( addr u -- )  : no.extensions  ( addr u -- )
     2drop -&13 throw ;      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
   [THEN]
   
   has? backtrace [IF]
 : interpret1 ( ... -- ... )  : interpret1 ( ... -- ... )
 [ has? backtrace [IF] ]  
     rp@ backtrace-rp0 !      rp@ backtrace-rp0 !
 [ [THEN] ]  
     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 ;
   
 : interpret ( ?? -- ?? ) \ gforth  : interpret ( ?? -- ?? ) \ gforth
     \ interpret/compile the (rest of the) input buffer      \ interpret/compile the (rest of the) input buffer
 [ has? backtrace [IF] ]  
     backtrace-rp0 @ >r      backtrace-rp0 @ >r
 [ [THEN] ]  
     ['] interpret1 catch      ['] interpret1 catch
 [ has? backtrace [IF] ]  
     r> backtrace-rp0 !      r> backtrace-rp0 !
     [ [THEN] ]  
     throw ;      throw ;
   [ELSE]
   : interpret ( ... -- ... )
       BEGIN
           ?stack [ has? EC 0= [IF] ] before-word [ [THEN] ] parse-name dup
       WHILE
           parser1 execute
       REPEAT
       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
   
Line 607 
Line 713 
 [THEN]  [THEN]
   
 has? new-input 0= [IF]  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 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 622 
Line 729 
     \G and return true; otherwise, return false.  A successful result      \G and return true; otherwise, return false.  A successful result
     \G includes receipt of a line containing 0 characters.      \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] ]
Line 631 
Line 738 
         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 Make the user input device the input source. Receive input into      \G Make the user input device the input source. Receive input into
Line 670 
Line 778 
   
 : 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]
Line 696 
Line 804 
     \G and input buffer. Interpret. When the parse area is empty,      \G and input buffer. Interpret. When the parse area is empty,
     \G restore the input source specification.      \G restore the input source specification.
 [ has? file [IF] ]  [ has? file [IF] ]
     loadfilename# @ >r      s" *evaluated string*" loadfilename>r
     1 loadfilename# ! \ "*evaluated string*"  
 [ [THEN] ]  [ [THEN] ]
     push-file #tib ! >tib !      push-file #tib ! >tib !
     >in off      input-start-line
     [ 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      pop-file
 [ has? file [IF] ]  [ has? file [IF] ]
     r> loadfilename# !      r>loadfilename
 [ [THEN] ]  [ [THEN] ]
     throw ;      throw ;
 [THEN]  [THEN]
Line 716 
Line 823 
   
 Defer 'quit  Defer 'quit
   
   has? os [IF]
 Defer .status  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" ;
   
 : (quit) ( -- )  : (quit) ( -- )
     \ exits only through THROW etc.      \ exits only through THROW etc.
 \    sp0 @ cell - handler @ &12 + ! \ !! kludge: fix the stack pointer  
     \ stored in the system's CATCH frame, so the stack depth will be 0  
     \ after the next THROW it catches (it may be off due to BOUNCEs or  
     \ because process-args left something on the stack)  
     BEGIN      BEGIN
         .status cr query interpret prompt          [ has? ec [IF] ] cr [ [ELSE] ]
     AGAIN ;          .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 has? file [IF] 6 [ELSE] 4 [THEN] * 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> ( -- addr u >in line# [addr u] )  : error> ( --  c-addr1 u1 c-addr2 u2 line# [addr u] )
     -1 error-stack +!      -1 error-stack +!
     error-stack dup @      error-stack dup @
     [ has? file [IF] 6 [ELSE] 4 [THEN] ] Literal * cells + cell+      /error * cells + cell+
     [ has? file [IF] 6 [ELSE] 4 [THEN] ] Literal cells bounds DO      /error cells bounds DO
         I @          I @
         cell +LOOP ;          cell +LOOP ;
 : >error ( addr u >in line# [addr u] -- )  
   : >error ( c-addr1 u1 c-addr2 u2 line# [addr u] -- )
     error-stack dup @ dup 1+      error-stack dup @ dup 1+
     max-errors 1- min error-stack !      max-errors 1- min error-stack !
     [ has? file [IF] 6 [ELSE] 4 [THEN] ] Literal * cells + cell+      /error * cells + cell+
     [ has? file [IF] 6 [ELSE] 4 [THEN] 1- ] Literal cells bounds swap DO      /error 1- cells bounds swap DO
         I !          I !
         -1 cells +LOOP ;          -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 @i{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...      \ !! not used...
     base @ decimal swap . base ! ;      base @ decimal swap . base ! ;
   
 : dec.r ( u -- ) \ gforth  : dec.r ( u n -- ) \ gforth
     \G Display @i{u} as a unsigned decimal number      \G Display @i{u} as a unsigned decimal number in a field @i{n}
     base @ decimal swap 0 .r base ! ;      \G characters wide.
       base @ >r decimal .r r> base ! ;
   
 : hex. ( u -- ) \ gforth  : hex. ( u -- ) \ gforth
     \G Display @i{u} as an unsigned hex number, prefixed with a "$" and      \G Display @i{u} as an unsigned hex number, prefixed with a "$" and
Line 773 
Line 904 
     \ !! not used...      \ !! not used...
     [char] $ emit base @ swap hex u. base ! ;      [char] $ emit base @ swap hex u. base ! ;
   
 : typewhite ( addr u -- ) \ gforth  : -trailing  ( c_addr u1 -- c_addr u2 ) \ string dash-trailing
     \G 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
   
Line 797 
Line 926 
   ELSE  .error    ELSE  .error
   THEN ;    THEN ;
   
 : .error-frame ( throwcode addr1 u1 n1 n2 [addr2 u2] -- throwcode )  : umin ( u1 u2 -- u )
 \ addr2 u2:     filename of included file - optional      2dup u>
       if
           swap
       then
       drop ;
   
   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  \ n2:           line number
 \ n1:           error position in input line      \ addr2 u2: parsed lexeme (should be marked as causing the error)
 \ addr1 u1:     input line  \ addr1 u1:     input line
   cr error-stack @      error-stack @
   IF      IF ( throwcode addr1 u1 n0 n1 n2 [addr2 u2] )
 [ has? file [IF] ]          [ has? file [IF] ] \ !! unbalanced stack effect
     ." in file included from "            over IF
                 cr ." in file included from "
     type ." :"      type ." :"
 [ [THEN] ]                0 dec.r  2drop 2drop
     dec.r  drop 2drop  
   ELSE    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] ]  [ has? file [IF] ]
       type ." :"              cr type ." :"
 [ [THEN] ]              [ [THEN] ] ( throwcode addr1 u1 n0 n1 n2 )
       dup >r dec.r ." : " 3 pick .error-string          dup 0 dec.r ." : " 5 pick .error-string
       r> IF \ if line# non-zero, there is a line          IF \ if line# non-zero, there is a line
           cr dup 2over type cr drop              cr .error-line
           nip -trailing 1- ( line-start index2 )  
           0 >r  BEGIN  
               2dup + c@ bl >  WHILE  
               r> 1+ >r  1- dup 0<  UNTIL  THEN  1+  
           ( line-start index1 )  
           typewhite  
           r> 1 max 0 ?do \ we want at least one "^", even if the length is 0  
               [char] ^ emit  
           loop  
       ELSE        ELSE
           2drop drop              2drop 2drop
       THEN        THEN
   THEN ;    THEN ;
   
Line 834 
Line 982 
   [ has? os [IF] ]    [ has? os [IF] ]
       >stderr        >stderr
   [ [THEN] ]    [ [THEN] ]
   source >in @ sourceline# [ has? file [IF] ]    input-error-data .error-frame
       sourcefilename  
   [ [THEN] ] .error-frame  
   error-stack @ 0 ?DO    error-stack @ 0 ?DO
     error>      error>
     .error-frame      .error-frame
Line 849 
Line 995 
   
 ' (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
     \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
Line 859 
Line 1013 
         [ has? compiler [IF] ]          [ has? compiler [IF] ]
         [compile] [          [compile] [
         [ [THEN] ]          [ [THEN] ]
           \ stack depths may be arbitrary here
         ['] '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          DoError
               \ stack depths may be arbitrary still (or again), so clear them
               clearstacks
         [ has? new-input [IF] ] clear-tibstack          [ has? new-input [IF] ] clear-tibstack
         [ [ELSE] ] r@ >tib ! r@ tibstack !          [ [ELSE] ] r@ >tib ! r@ tibstack !
         [ [THEN] ]          [ [THEN] ]
Line 873 
Line 1030 
   
 \ \ Cold Boot                                           13feb93py  \ \ Cold Boot                                           13feb93py
   
 : (bootmessage)  : (bootmessage) ( -- )
     ." GForth " version-string type      ." Gforth " version-string type
     ." , Copyright (C) 1995-2000 Free Software Foundation, Inc." cr      ." , Copyright (C) 1995-2011 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  ' (bootmessage) 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]
   
 AVariable init8 NIL init8 !  
   
 : cold ( -- ) \ gforth  : cold ( -- ) \ gforth
 [ has? backtrace [IF] ]  [ has? backtrace [IF] ]
Line 901 
Line 1064 
 [ has? file [IF] ]  [ has? file [IF] ]
     os-cold      os-cold
 [ [THEN] ]  [ [THEN] ]
   [ has? os [IF] ]
       set-encoding-fixed-width
     'cold      'cold
     init8 chainperform  [ [THEN] ]
 [ has? file [IF] ]  [ has? file [IF] ]
     loadfilename# off  
     process-args      process-args
     loadline off      loadline off
 [ [THEN] ]  [ [THEN] ]
Line 919 
Line 1083 
     [ 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]  [THEN]
   
 : boot ( path n **argv argc -- )  : boot ( path n **argv argc -- )
   [ has? no-userspace 0= [IF] ]
     main-task up!      main-task up!
   [ [THEN] ]
 [ has? os [IF] ]  [ has? os [IF] ]
     os-boot      os-boot
 [ [THEN] ]  [ [THEN] ]
   [ has? rom [IF] ]
       ram-shadow dup @ dup -1 <> >r u> r> and IF
           ram-shadow 2@  ELSE
           ram-mirror ram-size  THEN  ram-start swap move
   [ [THEN] ]
     sp@ sp0 !      sp@ sp0 !
 [ has? peephole [IF] ]  [ has? peephole [IF] ]
     primtable prepare-peephole-table TO peeptable      \ only needed for greedy static superinstruction selection
       \ primtable prepare-peephole-table TO peeptable
 [ [THEN] ]  [ [THEN] ]
 [ has? new-input [IF] ]  [ has? new-input [IF] ]
     current-input off      current-input off
 [ [THEN] ]  [ [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] ]
   [ has? os [IF] ]
     handler off      handler off
     ['] cold catch DoError cr      ['] cold catch dup -&2049 <> if \ broken pipe?
           DoError cr
       endif
   [ [ELSE] ]
       cold
   [ [THEN] ]
 [ has? os [IF] ]  [ has? os [IF] ]
     1 (bye) \ !! determin exit code from throw code?      1 (bye) \ !! determin exit code from throw code?
 [ [THEN] ]  [ [THEN] ]

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

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help