[gforth] / gforth / kernel / int.fs  

gforth: gforth/kernel/int.fs

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

version 1.90, Mon Jan 20 17:07:42 2003 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 384 
Line 387 
     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 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 696 
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 707 
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 727 
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 773 
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 784 
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 874 
Line 892 
 \ \ Cold Boot                                           13feb93py  \ \ Cold Boot                                           13feb93py
   
 : (bootmessage)  : (bootmessage)
     ." GForth " version-string type      ." Gforth " version-string type
     ." , Copyright (C) 1995-2003 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 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 944 
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.90  
changed lines
  Added in v.1.102
CVS Admin

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help