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

version 1.164, 2008/10/23 09:32:43 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 Free Software Foundation, Inc.  \ Copyright (C) 1995-2000,2004,2005,2007,2009,2010,2012 Free Software Foundation, Inc.
   
 \ This file is part of Gforth.  \ This file is part of Gforth.
   
Line 27  require ./basics.fs  \ bounds decimal he Line 27  require ./basics.fs  \ bounds decimal he
 require ./io.fs         \ type ...  require ./io.fs         \ type ...
 require ./nio.fs        \ . <# ...  require ./nio.fs        \ . <# ...
 require ./errore.fs     \ .error ...  require ./errore.fs     \ .error ...
 require ./version.fs    \ version-string  require kernel/version.fs \ version-string
   
 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 51  Defer source ( -- c-addr u ) \ core Line 51  Defer source ( -- c-addr u ) \ 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-obsolete 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  
 [ has? new-input [IF] ]  
     2dup input-lexeme!  
 [ [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
Line 113  Defer source ( -- c-addr u ) \ core Line 85  Defer source ( -- c-addr u ) \ core
   
 \ \ Number parsing                                      23feb93py  \ \ Number parsing                                      23feb93py
   
 \ number? number                                       23feb93py  \ (number?) number                                       23feb93py
   
 hex  hex
 const Create bases   0A , 10 ,   2 ,   0A ,  const Create bases   0A , 10 ,   2 ,   0A ,
Line 163  has? os 0= [IF] Line 135  has? os 0= [IF]
     over c@ '' = if      over c@ '' = if
         1 /string s'>unumber? exit          1 /string s'>unumber? exit
     endif      endif
     base @ >r  getbase sign? >r      base @ >r  getbase sign?
     0. 2swap      over if
     BEGIN ( d addr len )          >r 0. 2swap
         dup >r >number dup          BEGIN ( d addr len )
     WHILE \ there are characters left              dup >r >number dup
         dup r> -          WHILE \ there are characters left
     WHILE \ the last >number parsed something                  dup r> -
         dup 1- dpl ! over c@ [char] . =              WHILE \ the last >number parsed something
     WHILE \ the current char is '.'                      dup 1- dpl ! over c@ dp-char @ =
         1 /string                  WHILE \ the current char is '.'
     REPEAT  THEN \ there are unparseable characters left                          1 /string
         2drop rdrop false                  REPEAT  THEN \ there are unparseable characters left
               2drop rdrop false
           ELSE
               rdrop 2drop r> ?dnegate true
           THEN
     ELSE      ELSE
         rdrop 2drop r> ?dnegate true          drop 2drop 0. false THEN
     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
Line 207  has? os 0= [IF] Line 182  has? os 0= [IF]
         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 215  has? os 0= [IF] Line 190  has? os 0= [IF]
     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 287  has? f83headerstring [IF] Line 262  has? f83headerstring [IF]
 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 331  forth-wordlist current ! Line 306  forth-wordlist current !
   
 has? f83headerstring [IF]  has? f83headerstring [IF]
     \ to save space, Gforth EC limits words to 31 characters      \ to save space, Gforth EC limits words to 31 characters
       \ also, there's no predule concept in Gforth EC
     $80 constant alias-mask      $80 constant alias-mask
     $40 constant immediate-mask      $40 constant immediate-mask
     $20 constant restrict-mask      $20 constant restrict-mask
     $1f constant lcount-mask      $1f constant lcount-mask
 [ELSE]      [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 348  $20000000 constant restrict-mask Line 327  $20000000 constant restrict-mask
 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]  [THEN]
Line 447  has? f83headerstring [IF] Line 430  has? f83headerstring [IF]
     (name>x) tuck (x>int) ( w xt )      (name>x) tuck (x>int) ( w xt )
     swap immediate-mask and [ has? rom [IF] ] 0= [ [THEN] ] 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 454  const Create ???  0 , 3 , char ? c, char Line 446  const Create ???  0 , 3 , char ? c, char
 \ if we have a forthstart we can define head? with it  \ if we have a forthstart we can define head? with it
 \ otherwise leave out the head? check  \ otherwise leave out the head? check
   
   : one-head? ( addr -- f )
   \G heuristic check whether addr is a name token; may deliver false
   \G positives; addr must be a valid address
       dup dup aligned <>
       if
           drop false exit \ heads are aligned
       then
       dup cell+ @ alias-mask and 0= >r
       name>string dup $20 $1 within if
           rdrop 2drop false exit \ realistically the name is short
       then
       over + cfaligned over - 2dup bounds ?do \ should be a printable string
           i c@ bl < if
               2drop unloop rdrop false exit
           then
       loop
       + r> if \ check for valid aliases
           @ dup forthstart here within
           over ['] noop ['] lit-execute 1+ within or
           over dup aligned = and
           0= if
               drop false exit
           then
       then \ check for cfa - must be code field or primitive
       dup @ tuck 2 cells - = swap
       docol:  ['] lit-execute @ 1+ within or ;
   
 : head? ( addr -- f )  : head? ( addr -- f )
 \G heuristic check whether addr is a name token; may deliver false  \G heuristic check whether addr is a name token; may deliver false
 \G positives; addr must be a valid address; returns 1 for  \G positives; addr must be a valid address; returns 1 for
Line 464  const Create ???  0 , 3 , char ? c, char Line 483  const Create ???  0 , 3 , char ? c, char
     \ some code), which is typically not in the dictionary.      \ some code), which is typically not in the dictionary.
     \ we added a third iteration for working with code and ;code words.      \ we added a third iteration for working with code and ;code words.
     3 0 do      3 0 do
         dup dup aligned <> if \ protect @ against unaligned accesses          dup one-head? 0= if
             drop false unloop exit              drop false unloop exit
         then          endif
         dup @ dup          dup @ dup 0= if
         if ( addr addr1 )              2drop 1 unloop exit
             dup rot forthstart within          else
             if \ addr1 is outside forthstart..addr, not a head              dup rot forthstart within if
                 drop false unloop exit                  drop false unloop exit
             then ( addr1 )              then
         else \ 0 in the link field, no further checks  
             2drop 1 unloop exit \ this is very unsure, so return 1  
         then          then
     loop      loop
     \ in dubio pro:  
     drop true ;      drop true ;
   
 : >head-noprim ( cfa -- nt ) \ gforth  to-head-noprim  : >head-noprim ( cfa -- nt ) \ gforth  to-head-noprim
Line 550  has? flash [IF] ' flash! [ELSE] ' ! [THE Line 566  has? flash [IF] ' flash! [ELSE] ' ! [THE
 alias code-address! ( c_addr xt -- ) \ gforth  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>}.
     [ has? flash [IF] ]      [ has? flash [IF] ]
     dodoes: over flash! cell+ flash!      dodoes: over flash! cell+ flash!
     [ [ELSE] ]      [ [ELSE] ]
     dodoes: over ! cell+ !      dodoes: any-code! 
     [ [THEN] ] ;      [ [THEN] ] ;
   
 ' 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  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).
   
Line 633  Defer parser1 ( c-addr u -- ... xt) Line 650  Defer parser1 ( c-addr u -- ... xt)
 : parser ( c-addr u -- ... )  : parser ( c-addr u -- ... )
 \ text-interpret the word/number c-addr u, possibly producing a number  \ text-interpret the word/number c-addr u, possibly producing a number
     parser1 execute ;      parser1 execute ;
   
 has? ec [IF]  has? ec [IF]
     ' (name) Alias parse-name      ' (name) Alias parse-name
     : no.extensions  2drop -&13 throw ;      : no.extensions  2drop -&13 throw ;
Line 650  Defer parse-name ( "name" -- c-addr u ) Line 666  Defer parse-name ( "name" -- c-addr u )
 ' parse-name alias name ( -- c-addr u ) \ gforth-obsolete  ' parse-name alias name ( -- c-addr u ) \ gforth-obsolete
 \G old name for @code{parse-name}  \G old name for @code{parse-name}
           
   : no.extensions  ( addr u -- )
       2drop -&13 throw ;
   
   has? recognizer 0= [IF]
 Defer compiler-notfound1 ( c-addr count -- ... xt )  Defer compiler-notfound1 ( c-addr count -- ... xt )
 Defer interpreter-notfound1 ( c-addr count -- ... xt )  Defer interpreter-notfound1 ( c-addr count -- ... xt )
   
 : no.extensions  ( addr u -- )  
     2drop -&13 throw ;  
 ' no.extensions IS compiler-notfound1  ' no.extensions IS compiler-notfound1
 ' no.extensions IS interpreter-notfound1  ' no.extensions IS interpreter-notfound1
   [THEN]
   
 Defer before-word ( -- ) \ gforth  Defer before-word ( -- ) \ gforth
 \ called before the text interpreter parses the next word  \ called before the text interpreter parses the next word
 ' noop IS before-word  ' noop IS before-word
   
   Defer before-line ( -- ) \ gforth
   \ called before the text interpreter parses the next line
   ' noop IS before-line
   
 [THEN]  [THEN]
   
 has? backtrace [IF]  has? backtrace [IF]
 : interpret1 ( ... -- ... )  : interpret1 ( ... -- ... )
     rp@ backtrace-rp0 !      rp@ backtrace-rp0 !
       [ has? EC 0= [IF] ] before-line [ [THEN] ]
     BEGIN      BEGIN
         ?stack [ has? EC 0= [IF] ] before-word [ [THEN] ] parse-name dup          ?stack [ has? EC 0= [IF] ] before-word [ [THEN] ] parse-name dup
     WHILE      WHILE
Line 691  has? backtrace [IF] Line 716  has? backtrace [IF]
   
 \ 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
 : interpreter1 ( c-addr u -- ... xt )   : 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          nip nip name>int
     else      else
Line 707  has? backtrace [IF] Line 742  has? backtrace [IF]
     then ;      then ;
   
 ' interpreter1  IS  parser1  ' interpreter1  IS  parser1
   [THEN]
   
 \ \ Query Evaluate                                      07apr93py  \ \ Query Evaluate                                      07apr93py
   
Line 851  has? os [IF] Line 887  has? os [IF]
             [ has? OS [IF] ] >stderr [ [THEN] ]              [ has? OS [IF] ] >stderr [ [THEN] ]
             cr ." Can't print to stdout, leaving" cr              cr ." Can't print to stdout, leaving" cr
             \ if stderr does not work either, already DoError causes a hang              \ if stderr does not work either, already DoError causes a hang
             2 (bye)              -2 (bye)
         endif [ [THEN] ]          endif [ [THEN] ]
         refill  WHILE          refill  WHILE
             interpret prompt              interpret prompt
Line 891  max-errors /error * cells allot Line 927  max-errors /error * cells allot
   
 : input-error-data ( -- c-addr1 u1 c-addr2 u2 line# [addr u] )  : 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      \ error data for the current input, to be used by >error or .error-frame
     source input-lexeme 2@ sourceline#      source over >r save-mem over r> -
       input-lexeme 2@ >r + r> sourceline#
     [ has? file [IF] ] sourcefilename [ [THEN] ] ;      [ has? file [IF] ] sourcefilename [ [THEN] ] ;
   
 : dec. ( n -- ) \ gforth  : dec. ( n -- ) \ gforth
Line 932  Defer dobacktrace ( -- ) Line 969  Defer dobacktrace ( -- )
   ELSE  .error    ELSE  .error
   THEN ;    THEN ;
   
   [IFUNDEF] umin
 : umin ( u1 u2 -- u )  : umin ( u1 u2 -- u )
     2dup u>      2dup u>
     if      if
         swap          swap
     then      then
     drop ;      drop ;
   [THEN]
   
 Defer mark-start  Defer mark-start
 Defer mark-end  Defer mark-end
Line 1034  Defer mark-end Line 1073  Defer mark-end
     [ [ELSE] ] r> >tib !      [ [ELSE] ] r> >tib !
     [ [THEN] ] ;      [ [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) 1995-2008 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"
Line 1053  has? file [IF] Line 1099  has? file [IF]
 defer process-args  defer process-args
 [THEN]  [THEN]
   
 ' (bootmessage) IS bootmessage  ' gforth IS bootmessage
   
 has? os [IF]  has? os [IF]
 Defer 'cold ( -- ) \ gforth  tick-cold  Defer 'cold ( -- ) \ gforth  tick-cold
Line 1078  Defer 'cold ( -- ) \ gforth  tick-cold Line 1124  Defer 'cold ( -- ) \ gforth  tick-cold
     process-args      process-args
     loadline off      loadline off
 [ [THEN] ]  [ [THEN] ]
     bootmessage      1 (bye) ;
     quit ;  
   
 has? new-input 0= [IF]  has? new-input 0= [IF]
 : clear-tibstack ( -- )  : clear-tibstack ( -- )
Line 1098  has? new-input 0= [IF] Line 1143  has? new-input 0= [IF]
   
 : boot ( path n **argv argc -- )  : boot ( path n **argv argc -- )
 [ has? no-userspace 0= [IF] ]  [ has? no-userspace 0= [IF] ]
     main-task up!      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] ]  [ [THEN] ]
 [ has? os [IF] ]  [ has? os [IF] ]
     os-boot      os-boot
Line 1131  has? new-input 0= [IF] Line 1183  has? new-input 0= [IF]
     cold      cold
 [ [THEN] ]  [ [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] ]
 ;  ;
   

Removed from v.1.164  
changed lines
  Added in v.1.195


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