[gforth] / gforth / kernel / int.fs  

gforth: gforth/kernel/int.fs

Diff for /gforth/kernel/int.fs between version 1.79 and 1.102

version 1.79, Mon Apr 1 15:34:36 2002 UTC version 1.102, Tue Mar 11 16:07:26 2003 UTC
Line 286 
Line 286 
 : 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 298 
Line 301 
     \ get interpretation semantics of name      \ get interpretation semantics of name
     restrict-mask and      restrict-mask and
     if      if
         drop ['] ticking-compile-only-error          drop ['] compile-only-error
     else      else
         (cfa>int)          (cfa>int)
     then ;      then ;
Line 359 
Line 362 
   
 : 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.
     \ !! does not work se well for simple-see: trips on the first "0"      \ we added a third iteration for working with code and ;code words.
     2 0 do      3 0 do
         dup dup aligned <> if \ protect @ against unaligned accesses          dup dup aligned <> if \ protect @ against unaligned accesses
             drop false unloop exit              drop false unloop exit
         then          then
Line 376 
Line 380 
                 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-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 @ float+ 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 418 
Line 422 
   
 [THEN]  [THEN]
   
 : body> 0 >body - ;  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 ;
   
   ' ! 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 ;
Line 500 
Line 542 
 \ interpret                                            10mar92py  \ interpret                                            10mar92py
   
 Defer parser ( c-addr u -- )  Defer parser ( c-addr u -- )
 Defer parse-word ( -- c-addr count ) \ gforth  Defer parse-word ( "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-word
   
Line 657 
Line 699 
     \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      >in off
Line 668 
Line 709 
     ['] 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 688 
Line 729 
     \ after the next THROW it catches (it may be off due to BOUNCEs or      \ after the next THROW it catches (it may be off due to BOUNCEs or
     \ because process-args left something on the stack)      \ because process-args left something on the stack)
     BEGIN      BEGIN
         .status cr query interpret prompt          .status
           ['] cr catch if
               >stderr cr ." Can't print to stdout, leaving" cr
               \ if stderr does not work either, already DoError causes a hang
               2 (bye)
           endif
           query interpret prompt
     AGAIN ;      AGAIN ;
   
 ' (quit) IS 'quit  ' (quit) IS 'quit
Line 734 
Line 781 
     \ !! not used...      \ !! not used...
     [char] $ emit base @ swap hex u. base ! ;      [char] $ emit base @ swap hex u. base ! ;
   
 : typewhite ( addr u -- ) \ gforth  : typewhite ( addr n -- ) \ gforth
     \G 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 u+do
       0 max bounds ?do
         i c@ #tab = if \ check for tab          i c@ #tab = if \ check for tab
             #tab              #tab
         else          else
Line 745 
Line 793 
         emit          emit
     loop ;      loop ;
   
   : -trailing  ( c_addr u1 -- c_addr u2 ) \ string dash-trailing
   \G Adjust the string specified by @i{c-addr, u1} to remove all
   \G trailing spaces. @i{u2} is the length of the modified string.
       BEGIN
           dup
       WHILE
           1- 2dup + c@ bl <>
       UNTIL  1+  THEN ;
   
 DEFER DOERROR  DEFER DOERROR
   
 has? backtrace [IF]  has? backtrace [IF]
Line 835 
Line 892 
 \ \ 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-2003 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] ] ;
Line 865 
Line 922 
     'cold      'cold
     init8 chainperform      init8 chainperform
 [ has? file [IF] ]  [ has? file [IF] ]
     loadfilename# off      s" *the terminal*" loadfilename 2!
     process-args      process-args
     loadline off      loadline off
 [ [THEN] ]  [ [THEN] ]
Line 893 
Line 950 
 [ [THEN] ]  [ [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
Line 904 
Line 962 
     fp@ fp0 !      fp@ fp0 !
 [ [THEN] ]  [ [THEN] ]
     handler off      handler off
     ['] cold catch DoError cr      ['] cold catch dup -&2049 <> if \ broken pipe?
           DoError cr
       endif
 [ 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.79  
changed lines
  Added in v.1.102
CVS Admin

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help