[gforth] / gforth / kernel / int.fs  

gforth: gforth/kernel/int.fs

Diff for /gforth/kernel/int.fs between version 1.86 and 1.105

version 1.86, Fri Jan 10 21:19:59 2003 UTC version 1.105, Sun Jun 13 17:04:29 2004 UTC
Line 229 
Line 229 
   cell% field wordlist-extend \ wordlist extensions (eg bucket offset)    cell% field wordlist-extend \ wordlist extensions (eg bucket offset)
 end-struct wordlist-struct  end-struct wordlist-struct
   
   has? f83headerstring [IF]
   : f83find      ( addr len wordlist -- nt / false )
       wordlist-id @ (f83find) ;
   [ELSE]
 : f83find      ( addr len wordlist -- nt / false )  : f83find      ( addr len wordlist -- nt / false )
     wordlist-id @ (listlfind) ;      wordlist-id @ (listlfind) ;
   [THEN]
   
 : initvoc               ( wid -- )  : initvoc               ( wid -- )
   dup wordlist-map @ hash-method perform ;    dup wordlist-map @ hash-method perform ;
Line 260 
Line 265 
 \ The constants are defined as 32 bits, but then erased  \ The constants are defined as 32 bits, but then erased
 \ and overwritten by the right ones  \ and overwritten by the right ones
   
   has? f83headerstring [IF]
       \ to save space, Gforth EC limits words to 31 characters
       $80 constant alias-mask
       $40 constant immediate-mask
       $20 constant restrict-mask
       $1f constant lcount-mask
   [ELSE]
 $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 276 
Line 288 
 1 bits/char 3 - lshift 1 -  1 bits/char 3 - 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]
   
 \ higher level parts of find  \ higher level parts of find
   
Line 286 
Line 299 
 : 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 314 
     \ 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 ;
   
   has? f83headerstring [IF]
   : name>string ( nt -- addr count ) \ gforth     head-to-string
       \g @i{addr count} is the name of the word represented by @i{nt}.
       cell+ count lcount-mask and ;
   
   : ((name>))  ( nfa -- cfa )
       name>string + cfaligned ;
   
   : (name>x) ( nfa -- cfa w )
       \ cfa is an intermediate cfa and w is the flags cell of nfa
       dup ((name>))
       swap cell+ c@ dup alias-mask and 0=
       IF
           swap @ swap
       THEN ;
   [ELSE]
 : name>string ( nt -- addr count ) \ gforth     head-to-string  : name>string ( nt -- addr count ) \ gforth     head-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 317 
Line 349 
     IF      IF
         swap @ swap          swap @ swap
     THEN ;      THEN ;
   [THEN]
   
 : name>int ( nt -- xt ) \ gforth  : name>int ( nt -- xt ) \ gforth
     \G @i{xt} represents the interpretation semantics of the word      \G @i{xt} represents the interpretation semantics of the word
Line 384 
Line 417 
     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 539 
Line 572 
 \ 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 670 
Line 703 
   
 : extend-mem    ( addr1 u1 u -- addr addr2 u2 )  : extend-mem    ( addr1 u1 u -- addr addr2 u2 )
     \ extend memory block allocated from the heap by u aus      \ extend memory block allocated from the heap by u aus
     \ the (possibly reallocated piece is addr2 u2, the extension is at addr      \ the (possibly reallocated) piece is addr2 u2, the extension is at addr
     over >r + dup >r resize throw      over >r + dup >r resize throw
     r> over r> + -rot ;      r> over r> + -rot ;
 [THEN]  [THEN]
Line 696 
Line 729 
     \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 707 
Line 739 
     ['] 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 722 
Line 754 
   
 : (quit) ( -- )  : (quit) ( -- )
     \ exits only through THROW etc.      \ exits only through THROW etc.
 \    sp0 @ cell - handler @ &12 + ! \ !! kludge: fix the stack pointer  
     \ stored in the system's CATCH frame, so the stack depth will be 0  
     \ after the next THROW it catches (it may be off due to BOUNCEs or  
     \ 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 773 
Line 807 
     \ !! 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 784 
Line 819 
         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 859 
Line 903 
         [ has? compiler [IF] ]          [ has? compiler [IF] ]
         [compile] [          [compile] [
         [ [THEN] ]          [ [THEN] ]
           \ stack depths may be arbitrary here
         ['] 'quit CATCH dup          ['] 'quit CATCH dup
     WHILE      WHILE
         <# \ reset hold area, or we may get another error          <# \ reset hold area, or we may get another error
         DoError          DoError
               \ stack depths may be arbitrary still (or again), so clear them
               clearstacks
         [ has? new-input [IF] ] clear-tibstack          [ has? new-input [IF] ] clear-tibstack
         [ [ELSE] ] r@ >tib ! r@ tibstack !          [ [ELSE] ] r@ >tib ! r@ tibstack !
         [ [THEN] ]          [ [THEN] ]
Line 874 
Line 921 
 \ \ 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 904 
Line 951 
     '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 932 
Line 979 
 [ [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 943 
Line 991 
     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.86  
changed lines
  Added in v.1.105
CVS Admin

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help