[gforth] / gforth / kernel / int.fs  

gforth: gforth/kernel/int.fs

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

version 1.102, Tue Mar 11 16:07:26 2003 UTC version 1.116, Thu Jan 6 21:54:17 2005 UTC
Line 1 
Line 1 
 \ definitions needed for interpreter only  \ definitions needed for interpreter only
   
 \ Copyright (C) 1995-2000 Free Software Foundation, Inc.  \ Copyright (C) 1995-2000,2004 Free Software Foundation, Inc.
   
 \ This file is part of Gforth.  \ This file is part of Gforth.
   
Line 104 
Line 104 
 \ number? number                                       23feb93py  \ number? number                                       23feb93py
   
 hex  hex
 const Create bases   10 ,   2 ,   A , 100 ,  const Create bases   0A , 10 ,   2 ,   0A ,
 \                     16     2    10   character  \                    10   16     2     10
   
 \ !! protect BASE saving wrapper against exceptions  \ !! protect BASE saving wrapper against exceptions
 : getbase ( addr u -- addr' u' )  : getbase ( addr u -- addr' u' )
     over c@ [char] $ - dup 4 u<      2dup s" 0x" string-prefix? >r
       2dup s" 0X" string-prefix? r> or
       base @ #34 < and if
           hex 2 /string
       endif
       over c@ [char] # - dup 4 u<
     IF      IF
         cells bases + @ base ! 1 /string          cells bases + @ base ! 1 /string
     ELSE      ELSE
Line 123 
Line 128 
     THEN      THEN
     r> ;      r> ;
   
   : s'>unumber? ( addr u -- ud flag )
       \ convert string "C" or "C'" to character code
       dup 0= if
           false exit
       endif
       x@+/string 0 s" '" 2rot string-prefix? ;
   
 : s>unumber? ( addr u -- ud flag )  : s>unumber? ( addr u -- ud flag )
       over c@ '' = if
           1 /string s'>unumber? exit
       endif
     base @ >r  dpl on  getbase      base @ >r  dpl on  getbase
     0. 2swap      0. 2swap
     BEGIN ( d addr len )      BEGIN ( d addr len )
Line 229 
Line 244 
   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 280 
 \ 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 303 
 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 306 
Line 334 
         (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 320 
Line 364 
     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 557 
Line 602 
 ' no.extensions IS compiler-notfound  ' no.extensions IS compiler-notfound
 ' no.extensions IS interpreter-notfound  ' no.extensions IS interpreter-notfound
   
   Defer before-word ( -- ) \ gforth
   \ called before the text interpreter parses the next word
   ' noop IS before-word
   
 : interpret1 ( ... -- ... )  : interpret1 ( ... -- ... )
 [ has? backtrace [IF] ]  [ has? backtrace [IF] ]
     rp@ backtrace-rp0 !      rp@ backtrace-rp0 !
 [ [THEN] ]  [ [THEN] ]
     BEGIN      BEGIN
         ?stack name dup          ?stack before-word name dup
     WHILE      WHILE
         parser          parser
     REPEAT      REPEAT
Line 673 
Line 722 
   
 : 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 724 
Line 773 
   
 : (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          .status
         ['] cr catch if          ['] cr catch if
Line 743 
Line 788 
 \ \ DOERROR (DOERROR)                                   13jun93jaw  \ \ DOERROR (DOERROR)                                   13jun93jaw
   
 8 Constant max-errors  8 Constant max-errors
   4 has? file 2 and + Constant /error
 Variable error-stack  0 error-stack !  Variable error-stack  0 error-stack !
 max-errors has? file [IF] 6 [ELSE] 4 [THEN] * cells allot  max-errors /error * cells allot
 \ format of one cell:  \ format of one cell:
 \ source ( addr u )  \ source ( addr u )
 \ >in  \ >in
Line 754 
Line 800 
 : error> ( -- addr u >in line# [addr u] )  : error> ( -- addr u >in line# [addr u] )
     -1 error-stack +!      -1 error-stack +!
     error-stack dup @      error-stack dup @
     [ has? file [IF] 6 [ELSE] 4 [THEN] ] Literal * cells + cell+      /error * cells + cell+
     [ has? file [IF] 6 [ELSE] 4 [THEN] ] Literal cells bounds DO      /error cells bounds DO
         I @          I @
         cell +LOOP ;          cell +LOOP ;
 : >error ( addr u >in line# [addr u] -- )  : >error ( addr u >in line# [addr u] -- )
     error-stack dup @ dup 1+      error-stack dup @ dup 1+
     max-errors 1- min error-stack !      max-errors 1- min error-stack !
     [ has? file [IF] 6 [ELSE] 4 [THEN] ] Literal * cells + cell+      /error * cells + cell+
     [ has? file [IF] 6 [ELSE] 4 [THEN] 1- ] Literal cells bounds swap DO      /error 1- cells bounds swap DO
         I !          I !
         -1 cells +LOOP ;          -1 cells +LOOP ;
   
Line 771 
Line 817 
     \ !! not used...      \ !! not used...
     base @ decimal swap . base ! ;      base @ decimal swap . base ! ;
   
 : dec.r ( u -- ) \ gforth  : dec.r ( u n -- ) \ gforth
     \G Display @i{u} as a unsigned decimal number      \G Display @i{u} as a unsigned decimal number in a field @i{n}
     base @ decimal swap 0 .r base ! ;      \G characters wide.
       base @ >r decimal .r r> base ! ;
   
 : hex. ( u -- ) \ gforth  : hex. ( u -- ) \ gforth
     \G Display @i{u} as an unsigned hex number, prefixed with a "$" and      \G Display @i{u} as an unsigned hex number, prefixed with a "$" and
Line 781 
Line 828 
     \ !! not used...      \ !! not used...
     [char] $ emit base @ swap hex u. base ! ;      [char] $ emit base @ swap hex u. base ! ;
   
 : typewhite ( addr n -- ) \ gforth  
 \G Like type, but white space is printed instead of the characters.  
     \ bounds u+do  
     0 max bounds ?do  
         i c@ #tab = if \ check for tab  
             #tab  
         else  
             bl  
         then  
         emit  
     loop ;  
   
 : -trailing  ( c_addr u1 -- c_addr u2 ) \ string dash-trailing  : -trailing  ( c_addr u1 -- c_addr u2 ) \ string dash-trailing
 \G Adjust the string specified by @i{c-addr, u1} to remove all  \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.  \G trailing spaces. @i{u2} is the length of the modified string.
Line 815 
Line 850 
   ELSE  .error    ELSE  .error
   THEN ;    THEN ;
   
   : umin ( u1 u2 -- u )
       2dup u>
       if
           swap
       then
       drop ;
   
   Defer mark-start
   Defer mark-end
   
   :noname ." >>>" ; IS mark-start
   :noname ." <<<" ; IS mark-end
   
   : .error-line ( addr1 u1 n1 -- )
       \ print error ending at char n1 in line addr1 u1
       \ should work with UTF-8 (whitespace check looks ok)
       over umin \ protect against wrong n1
       swap >r ( addr1 n1 R: u1 )
       -trailing 1- \ last non-space
       0 >r  BEGIN \ search for the first non-space
           2dup + c@ bl >  WHILE
           r> 1+ >r  1- dup 0<  UNTIL  THEN  1+
       ( addr1 n2 r: u1 namelen )
       2dup type mark-start
       r> -rot r> swap /string ( namelen addr2 u2 )
       >r swap 2dup type mark-end ( addr2 namelen r: u2 )
       r> swap /string type ;
   
 : .error-frame ( throwcode addr1 u1 n1 n2 [addr2 u2] -- throwcode )  : .error-frame ( throwcode addr1 u1 n1 n2 [addr2 u2] -- throwcode )
 \ addr2 u2:     filename of included file - optional  \ addr2 u2:     filename of included file - optional
 \ n2:           line number  \ n2:           line number
 \ n1:           error position in input line  \ n1:           error position in input line
 \ addr1 u1:     input line  \ addr1 u1:     input line
   cr error-stack @    cr error-stack @
   IF    IF ( throwcode addr1 u1 n1 n2 [addr2 u2] )
 [ has? file [IF] ]  [ has? file [IF] ] \ !! unbalanced stack effect
     ." in file included from "      ." in file included from "
     type ." :"      type ." :"
 [ [THEN] ]  [ [THEN] ] ( throwcode addr1 u1 n1 n2 )
     dec.r  drop 2drop      0 dec.r  drop 2drop
   ELSE    ELSE ( throwcode addr1 u1 n1 n2 [addr2 u2] )
 [ has? file [IF] ]  [ has? file [IF] ]
       type ." :"        type ." :"
 [ [THEN] ]  [ [THEN] ] ( throwcode addr1 u1 n1 n2 )
       dup >r dec.r ." : " 3 pick .error-string        dup 0 dec.r ." : " 4 pick .error-string
       r> IF \ if line# non-zero, there is a line        IF \ if line# non-zero, there is a line
           cr dup 2over type cr drop            cr .error-line
           nip -trailing 1- ( line-start index2 )  
           0 >r  BEGIN  
               2dup + c@ bl >  WHILE  
               r> 1+ >r  1- dup 0<  UNTIL  THEN  1+  
           ( line-start index1 )  
           typewhite  
           r> 1 max 0 ?do \ we want at least one "^", even if the length is 0  
               [char] ^ emit  
           loop  
       ELSE        ELSE
           2drop drop            2drop drop
       THEN        THEN
Line 852 
Line 906 
   [ has? os [IF] ]    [ has? os [IF] ]
       >stderr        >stderr
   [ [THEN] ]    [ [THEN] ]
   source >in @ sourceline# [ has? file [IF] ]    source >in @ sourceline# [ has? file [IF] ] \ !! unbalanced stack effect
       sourcefilename        sourcefilename
   [ [THEN] ] .error-frame    [ [THEN] ] .error-frame
   error-stack @ 0 ?DO    error-stack @ 0 ?DO
Line 877 
Line 931 
         [ 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 893 
Line 950 
   
 : (bootmessage)  : (bootmessage)
     ." Gforth " version-string type      ." Gforth " version-string type
     ." , Copyright (C) 1995-2003 Free Software Foundation, Inc." cr      ." , Copyright (C) 1995-2003,2004 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"
Line 919 
Line 976 
 [ has? file [IF] ]  [ has? file [IF] ]
     os-cold      os-cold
 [ [THEN] ]  [ [THEN] ]
       set-encoding-fixed-width
     'cold      'cold
     init8 chainperform      init8 chainperform
 [ has? file [IF] ]  [ has? file [IF] ]

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

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help