[gforth] / gforth / kernel / int.fs  

gforth: gforth/kernel/int.fs

Diff for /gforth/kernel/int.fs between version 1.158 and 1.175

version 1.158, Fri Jul 6 12:54:57 2007 UTC version 1.175, Sun Apr 11 15:37:22 2010 UTC
Line 1 
Line 1 
 \ definitions needed for interpreter only  \ definitions needed for interpreter only
   
 \ Copyright (C) 1995-2000,2004,2005 Free Software Foundation, Inc.  \ Copyright (C) 1995-2000,2004,2005,2007,2009 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 52 
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-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 114 
Line 85 
   
 \ \ 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 141 
Line 112 
     THEN      THEN
     r> ;      r> ;
   
   : ?dnegate ( d1 f -- d2 )
       if
           dnegate
       then ;
   
 has? os 0= [IF]  has? os 0= [IF]
 : x@+/string ( addr u -- addr' u' c )  : x@+/string ( addr u -- addr' u' c )
     over c@ >r 1 /string r> ;      over c@ >r 1 /string r> ;
Line 153 
Line 129 
     endif      endif
     x@+/string 0 s" '" 2rot string-prefix? ;      x@+/string 0 s" '" 2rot string-prefix? ;
   
 : s>unumber? ( addr u -- ud flag ) \ gforth  : s>unumber? ( c-addr u -- ud flag ) \ gforth
     \G converts string addr u into ud, flag indicates success      \G converts string c-addr u into ud, flag indicates success
     dpl on      dpl on
     over c@ '' = if      over c@ '' = if
         1 /string s'>unumber? exit          1 /string s'>unumber? exit
     endif      endif
     base @ >r  getbase      base @ >r  getbase sign?
     0. 2swap      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 170 
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
Line 184 
Line 163 
     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 206 
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 214 
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 286 
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 330 
Line 306 
   
 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 347 
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]  [THEN]
Line 446 
Line 430 
     (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 558 
Line 551 
     dodoes: over ! cell+ !      dodoes: over ! cell+ !
     [ [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 690 
Line 679 
   
 \ 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]
   
 \ 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 832 
Line 830 
 has? os [IF]  has? os [IF]
     Defer .status      Defer .status
 [ELSE]  [ELSE]
       [IFUNDEF] bye
 : (bye)     ( 0 -- ) \ back to DOS  : (bye)     ( 0 -- ) \ back to DOS
     drop 5 emit ;      drop 5 emit ;
   
 : bye ( -- )  0 (bye) ;  : bye ( -- )  0 (bye) ;
 [THEN]  [THEN]
   [THEN]
   
 : prompt        state @ IF ."  compiled" EXIT THEN ."  ok" ;  : prompt        state @ IF ."  compiled" EXIT THEN ."  ok" ;
   
Line 1035 
Line 1035 
   
 : (bootmessage) ( -- )  : (bootmessage) ( -- )
     ." Gforth " version-string type      ." Gforth " version-string type
     ." , Copyright (C) 1995-2006 Free Software Foundation, Inc." cr      ." , Copyright (C) 1995-2009 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"

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

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help