[gforth] / gforth / kernel / int.fs  

gforth: gforth/kernel/int.fs

Diff for /gforth/kernel/int.fs between version 1.152 and 1.160

version 1.152, Fri May 26 21:18:45 2006 UTC version 1.160, Mon Dec 31 17:34:59 2007 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 Free Software Foundation, Inc.
   
 \ This file is part of Gforth.  \ This file is part of Gforth.
   
Line 141 
Line 141 
     THEN      THEN
     r> ;      r> ;
   
   : ?dnegate ( d1 f -- d2 )
       if
           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 )  : s'>unumber? ( addr u -- ud flag )
     \ convert string "C" or "C'" to character code      \ convert string "C" or "C'" to character code
     dup 0= if      dup 0= if
Line 148 
Line 158 
     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? >r
     0. 2swap      0. 2swap
     BEGIN ( d addr len )      BEGIN ( d addr len )
         dup >r >number dup          dup >r >number dup
Line 165 
Line 175 
     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
     r> base ! ;      r> base ! ;
   
Line 179 
Line 189 
     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 378 
Line 385 
     then ;      then ;
   
 has? f83headerstring [IF]  has? f83headerstring [IF]
 : name>string ( nt -- addr count ) \ gforth     head-to-string  : 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+ count lcount-mask and ;      cell+ count lcount-mask and ;
   
Line 393 
Line 400 
         swap @ swap          swap @ swap
     THEN ;      THEN ;
 [ELSE]  [ELSE]
 : name>string ( nt -- addr count ) \ gforth     head-to-string  : 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 409 
Line 416 
     THEN ;      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 [ has? rom [IF] ] 0= [ [THEN] ]      (name>x) restrict-mask and [ has? rom [IF] ] 0= [ [THEN] ]
Line 476 
Line 483 
   
 : >head-noprim ( cfa -- nt ) \ gforth  to-head-noprim  : >head-noprim ( cfa -- nt ) \ gforth  to-head-noprim
     \ also heuristic      \ also heuristic
     dup forthstart - max-name-length @ float+ cell+ min cell max 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 510 
Line 519 
   
 [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 533 
Line 542 
         drop 0          drop 0
     endif ;      endif ;
   
   has? prims [IF]
       : flash! ! ;
       : flashc! c! ;
   [THEN]
   
 has? flash [IF] ' flash! [ELSE] ' ! [THEN]  has? flash [IF] ' flash! [ELSE] ' ! [THEN]
 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}.
Line 665 
Line 679 
     backtrace-rp0 @ >r      backtrace-rp0 @ >r
     ['] interpret1 catch      ['] interpret1 catch
     r> backtrace-rp0 !      r> backtrace-rp0 !
     throw>error ;      throw ;
 [ELSE]  [ELSE]
 : interpret ( ... -- ... )  : interpret ( ... -- ... )
     BEGIN      BEGIN
Line 817 
Line 831 
   
 Defer 'quit  Defer 'quit
   
 has? ec 0= [IF]  has? os [IF]
 Defer .status  Defer .status
   [ELSE]
   : (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" ;
Line 842 
Line 861 
   
 \ \ DOERROR (DOERROR)                                   13jun93jaw  \ \ DOERROR (DOERROR)                                   13jun93jaw
   
 has? ec 0= [IF]  has? os [IF]
 8 Constant max-errors  8 Constant max-errors
 5 has? file 2 and + Constant /error  5 has? file 2 and + Constant /error
 Variable error-stack  0 error-stack !  Variable error-stack  0 error-stack !
Line 1016 
Line 1035 
   
 \ \ Cold Boot                                           13feb93py  \ \ Cold Boot                                           13feb93py
   
 : (bootmessage)  : (bootmessage) ( -- )
     ." Gforth " version-string type      ." Gforth " version-string type
     ." , Copyright (C) 1995-2006 Free Software Foundation, Inc." cr      ." , Copyright (C) 1995-2006,2007 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 \ gforth  defer bootmessage ( -- ) \ gforth
 \G Hook (deferred word) executed right after interpreting the OS  \G Hook (deferred word) executed right after interpreting the OS
 \G command-line arguments.  Normally prints the Gforth startup  \G command-line arguments.  Normally prints the Gforth startup
 \G message.  \G message.
Line 1035 
Line 1054 
   
 ' (bootmessage) IS bootmessage  ' (bootmessage) IS bootmessage
   
 has? ec 0= [IF]  has? os [IF]
 Defer 'cold ( -- ) \ gforth  tick-cold  Defer 'cold ( -- ) \ gforth  tick-cold
 \G Hook (deferred word) for things to do right before interpreting the  \G Hook (deferred word) for things to do right before interpreting the
 \G OS command-line arguments.  Normally does some initializations that  \G OS command-line arguments.  Normally does some initializations that
Line 1050 
Line 1069 
 [ has? file [IF] ]  [ has? file [IF] ]
     os-cold      os-cold
 [ [THEN] ]  [ [THEN] ]
 [ has? ec 0= [IF] ]  [ has? os [IF] ]
     set-encoding-fixed-width      set-encoding-fixed-width
     'cold      'cold
 [ [THEN] ]  [ [THEN] ]
Line 1102 
Line 1121 
 [ has? floating [IF] ]  [ has? floating [IF] ]
     fp@ fp0 !      fp@ fp0 !
 [ [THEN] ]  [ [THEN] ]
 [ has? ec 0= [IF] ]  [ has? os [IF] ]
     handler off      handler off
     ['] cold catch dup -&2049 <> if \ broken pipe?      ['] cold catch dup -&2049 <> if \ broken pipe?
         DoError cr          DoError cr

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

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help