[gforth] / gforth / kernel / int.fs  

gforth: gforth/kernel/int.fs

Diff for /gforth/kernel/int.fs between version 1.69 and 1.84

version 1.69, Sun Jan 28 22:43:39 2001 UTC version 1.84, Wed Jan 8 10:25:34 2003 UTC
Line 274 
Line 274 
                           [ELSE] 0 1 cells 1- times c, [THEN]                            [ELSE] 0 1 cells 1- times c, [THEN]
 $1fffffff constant lcount-mask  $1fffffff constant lcount-mask
 1 bits/char 3 - lshift 1 -  1 bits/char 3 - lshift 1 -
 -1 cells allot  bigendian [IF]   c, $FF 1 cells 1- times  -1 cells allot  bigendian [IF]   c, -1 1 cells 1- times
                           [ELSE] $FF 1 cells 1- times c, [THEN]                            [ELSE] -1 1 cells 1- times c, [THEN]
   
 \ higher level parts of find  \ higher level parts of find
   
Line 283 
Line 283 
     \ true becomes 1, false -1      \ true becomes 1, false -1
     0= 2* 1+ ;      0= 2* 1+ ;
   
 : compile-only-error ( ... -- )  : ticking-compile-only-error ( ... -- )
     -&14 throw ;      -&2048 throw ;
   
 : (cfa>int) ( cfa -- xt )  : (cfa>int) ( cfa -- xt )
 [ has? compiler [IF] ]  [ has? compiler [IF] ]
Line 298 
Line 298 
     \ get interpretation semantics of name      \ get interpretation semantics of name
     restrict-mask and      restrict-mask and
     if      if
         drop ['] compile-only-error          drop ['] ticking-compile-only-error
     else      else
         (cfa>int)          (cfa>int)
     then ;      then ;
Line 322 
Line 322 
     \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{compile-only-error}, which performs @code{-14 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
     \G Like @code{name>int}, but perform @code{-14 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
     if      if
         compile-only-error \ does not return          ticking-compile-only-error \ does not return
     then      then
     (cfa>int) ;      (cfa>int) ;
   
Line 350 
Line 350 
     (name>x) tuck (x>int) ( w xt )      (name>x) tuck (x>int) ( w xt )
     swap immediate-mask and flag-sign ;      swap immediate-mask and flag-sign ;
   
 const Create ???  0 , 3 c, 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
   
 [IFDEF] forthstart  [IFDEF] forthstart
Line 359 
Line 359 
   
 : 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.
     2 0 do      \ we added a third iteration for working with code and ;code words.
       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 375 
Line 377 
                 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:
Line 384 
Line 386 
 : >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; finds only names with up to 32 chars
     $25 cell do ( cfa )      $25 cell do ( cfa )
         dup i - dup @ [ alias-mask lcount-mask or ] literal and ( cfa len|alias )          dup i - dup @ [ alias-mask lcount-mask or ] literal
           [ 1 bits/char 3 - lshift 1 - 1 bits/char 1 - lshift or
           -1 cells allot bigendian [IF]   c, -1 1 cells 1- times
           [ELSE] -1 1 cells 1- times c, [THEN] ]
           and ( cfa len|alias )
         swap + cell + cfaligned over alias-mask + =          swap + cell + cfaligned over alias-mask + =
         if ( cfa )          if ( cfa )
             dup i - cell - dup head?              dup i - cell - dup head?
Line 400 
Line 406 
   
 : >head-noprim ( cfa -- nt ) \ gforth  to-head-noprim  : >head-noprim ( cfa -- nt ) \ gforth  to-head-noprim
     $25 cell do ( cfa )      $25 cell do ( cfa )
         dup i - dup @ [ alias-mask lcount-mask or ] literal and ( cfa len|alias )          dup i - dup @ [ alias-mask lcount-mask or ] literal
           [ 1 bits/char 3 - lshift 1 - 1 bits/char 1 - lshift or
           -1 cells allot bigendian [IF]   c, -1 1 cells 1- times
           [ELSE] -1 1 cells 1- times c, [THEN] ]
           and ( cfa len|alias )
         swap + cell + cfaligned over alias-mask + =          swap + cell + cfaligned over alias-mask + =
         if ( cfa ) i - cell - unloop exit          if ( cfa ) i - cell - unloop exit
         then          then
Line 409 
Line 419 
   
 [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 ;
   
   [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 491 
Line 524 
 \ interpret                                            10mar92py  \ interpret                                            10mar92py
   
 Defer parser ( c-addr u -- )  Defer parser ( c-addr u -- )
 Defer name ( -- c-addr count ) \ gforth  Defer parse-word ( -- c-addr count ) \ gforth
 \G Get the next word from the input buffer  \G Get the next word from the input buffer
 ' (name) IS name  ' (name) IS parse-word
   
   ' parse-word alias name ( -- c-addr u ) \ gforth-obsolete
   \G old name for @code{parse-word}
   
 Defer compiler-notfound ( c-addr count -- )  Defer compiler-notfound ( c-addr count -- )
 Defer interpreter-notfound ( c-addr count -- )  Defer interpreter-notfound ( c-addr count -- )
   
Line 805 
Line 842 
     [ has? new-input 0= [IF] ] >tib @ >r [ [THEN] ]      [ has? new-input 0= [IF] ] >tib @ >r [ [THEN] ]
     BEGIN      BEGIN
         [ has? compiler [IF] ]          [ has? compiler [IF] ]
         postpone [          [compile] [
         [ [THEN] ]          [ [THEN] ]
         ['] 'quit CATCH dup          ['] 'quit CATCH dup
     WHILE      WHILE
Line 840 
Line 877 
 ' noop IS 'cold  ' noop IS 'cold
   
   
 Variable init8  AVariable init8 NIL init8 !
   
 : cold ( -- ) \ gforth  : cold ( -- ) \ gforth
 [ has? backtrace [IF] ]  [ has? backtrace [IF] ]
     rp@ backtrace-rp0 !      rp@ backtrace-rp0 !
 [ [THEN] ]  [ [THEN] ]
 [ has? file [IF] ]  [ has? file [IF] ]
     pathstring 2@ fpath only-path      os-cold
     init-included-files  
 [ [THEN] ]  [ [THEN] ]
     'cold      'cold
     init8 chainperform      init8 chainperform
Line 877 
Line 913 
 : boot ( path n **argv argc -- )  : boot ( path n **argv argc -- )
     main-task up!      main-task up!
 [ has? os [IF] ]  [ has? os [IF] ]
     stdout TO outfile-id      os-boot
     stdin  TO infile-id  
 \ !! [ [THEN] ]  
 \ !! [ has? file [IF] ]  
     argc ! argv ! pathstring 2!  
 [ [THEN] ]  [ [THEN] ]
     sp@ sp0 !      sp@ sp0 !
   [ has? peephole [IF] ]
       primtable prepare-peephole-table TO peeptable
   [ [THEN] ]
 [ has? new-input [IF] ]  [ has? new-input [IF] ]
     current-input off      current-input off
 [ [THEN] ]  [ [THEN] ]

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

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help