[gforth] / gforth / kernel / basics.fs  

gforth: gforth/kernel/basics.fs

Diff for /gforth/kernel/basics.fs between version 1.5 and 1.41

version 1.5, Sat Sep 13 12:05:51 1997 UTC version 1.41, Mon Aug 18 19:29:15 2003 UTC
Line 1 
Line 1 
 \ kernel.fs    GForth kernel                        17dec92py  \ kernel.fs    GForth kernel                        17dec92py
   
 \ Copyright (C) 1995 Free Software Foundation, Inc.  \ Copyright (C) 1995,1998,2000,2003 Free Software Foundation, Inc.
   
 \ This file is part of Gforth.  \ This file is part of Gforth.
   
Line 16 
Line 16 
   
 \ You should have received a copy of the GNU General Public License  \ You should have received a copy of the GNU General Public License
 \ along with this program; if not, write to the Free Software  \ along with this program; if not, write to the Free Software
 \ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.  \ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA.
   
 \ Idea and implementation: Bernd Paysan (py)  \ Idea and implementation: Bernd Paysan (py)
   
 HEX  \ Needs:
   
   require ./vars.fs
   require ../compat/strcomp.fs
   
   hex
   
 \ labels for some code addresses  \ labels for some code addresses
   
Line 30 
Line 35 
   
 [IFUNDEF] r@  [IFUNDEF] r@
 ' i Alias r@ ( -- w ; R: w -- w ) \ core r-fetch  ' i Alias r@ ( -- w ; R: w -- w ) \ core r-fetch
 \G copy w from the return stack to the data stack  
 [THEN]  [THEN]
   
 \ !! this is machine-dependent, but works on all but the strangest machines  \ !! this is machine-dependent, but works on all but the strangest machines
   
 : maxaligned ( addr -- f-addr ) \ float  : maxaligned ( addr1 -- addr2 ) \ gforth
       \G @i{addr2} is the first address after @i{addr1} that satisfies
       \G all alignment restrictions.
     [ /maxalign 1 - ] Literal + [ 0 /maxalign - ] Literal and ;      [ /maxalign 1 - ] Literal + [ 0 /maxalign - ] Literal and ;
 \ !! machine-dependent and won't work if "0 >body" <> "0 >body maxaligned"  \ !! machine-dependent and won't work if "0 >body" <> "0 >body
       \G maxaligned"
 ' maxaligned Alias cfaligned ( addr1 -- addr2 ) \ gforth  ' maxaligned Alias cfaligned ( addr1 -- addr2 ) \ gforth
   \G @i{addr2} is the first address after @i{addr1} that is aligned for
   \G a code field (i.e., such that the corresponding body is maxaligned).
   
 : chars ( n1 -- n2 ) \ core  : chars ( n1 -- n2 ) \ core
   \G @i{n2} is the number of address units of @i{n1} chars.""
 ; immediate  ; immediate
   
   
Line 52 
Line 62 
   
 \ UNUSED                                                17may93jaw  \ UNUSED                                                17may93jaw
   
 has? ec  has? ec [IF]
 [IF]  unlock ram-dictionary borders nip lock
 unlock ram-dictionary area nip lock  AConstant dictionary-end
 Constant dictionary-end  
 [ELSE]  [ELSE]
       has? header [IF]
 : dictionary-end ( -- addr )  : dictionary-end ( -- addr )
     forthstart [ 3 cells ] Aliteral @ + ;              forthstart [ 3 cells image-header + ] Aliteral @ + ;
       [ELSE]
           : forthstart 0 ;
           : dictionary-end ( -- addr )
               forthstart [ has? kernel-size ] Literal + ;
       [THEN]
 [THEN]  [THEN]
   
   : usable-dictionary-end ( -- addr )
       dictionary-end [ word-pno-size pad-minsize + ] Literal - ;
   
 : unused ( -- u ) \ core-ext  : unused ( -- u ) \ core-ext
     dictionary-end here - [ word-pno-size pad-minsize + ] Literal - ;      \G Return the amount of free space remaining (in address units) in
       \G the region addressed by @code{here}.
       usable-dictionary-end here - ;
   
   has? ec [IF]
   : in-dictionary? ( x -- f )
       dictionary-end u< ;
   [ELSE]
   : in-dictionary? ( x -- f )
       forthstart dictionary-end within ;
   [THEN]
   
 \ here is used for pad calculation!  \ here is used for pad calculation!
   
 : dp    ( -- addr ) \ gforth  : dp    ( -- addr ) \ gforth
     dpp @ ;      dpp @ ;
 : here  ( -- here ) \ core  : here  ( -- addr ) \ core
       \G Return the address of the next free location in data space.
     dp @ ;      dp @ ;
   
 \ on off                                               23feb93py  \ on off                                               23feb93py
   
 \ on is used by docol:  \ on is used by docol:
 : on  ( addr -- ) \ gforth  : on  ( a-addr -- ) \ gforth
       \G Set the (value of the) variable  at @i{a-addr} to @code{true}.
     true  swap ! ;      true  swap ! ;
 : off ( addr -- ) \ gforth  : off ( a-addr -- ) \ gforth
       \G Set the (value of the) variable at @i{a-addr} to @code{false}.
     false swap ! ;      false swap ! ;
   
 \ dabs roll                                           17may93jaw  \ dabs roll                                           17may93jaw
   
 : dabs ( d1 -- d2 ) \ double  : dabs ( d -- ud ) \ double d-abs
     dup 0< IF dnegate THEN ;      dup 0< IF dnegate THEN ;
   
 : roll  ( x0 x1 .. xn n -- x1 .. xn x0 ) \ core-ext  : roll  ( x0 x1 .. xn n -- x1 .. xn x0 ) \ core-ext
Line 92 
Line 123 
   
 : place  ( addr len to -- ) \ gforth  : place  ( addr len to -- ) \ gforth
     over >r  rot over 1+  r> move c! ;      over >r  rot over 1+  r> move c! ;
 : bounds ( beg count -- end beg ) \ gforth  : bounds ( addr u -- addr+u addr ) \ gforth
       \G Given a memory block represented by starting address @i{addr}
       \G and length @i{u} in aus, produce the end address @i{addr+u} and
       \G the start address in the right order for @code{u+do} or
       \G @code{?do}.
     over + swap ;      over + swap ;
   
 \ (word)                                               22feb93py  \ (word)                                               22feb93py
Line 128 
Line 163 
     true EXIT      true EXIT
   THEN    THEN
   toupper [char] 0 - dup 9 u> IF    toupper [char] 0 - dup 9 u> IF
     [ 'A '9 1 + -  ] literal -      [ char A char 9 1 + -  ] literal -
     dup 9 u<= IF      dup 9 u<= IF
       drop false EXIT        drop false EXIT
     THEN      THEN
Line 141 
Line 176 
 : accumulate ( +d0 addr digit - +d1 addr )  : accumulate ( +d0 addr digit - +d1 addr )
   swap >r swap  base @  um* drop rot  base @  um* d+ r> ;    swap >r swap  base @  um* drop rot  base @  um* d+ r> ;
   
 : >number ( d addr count -- d addr count ) \ core  : >number ( ud1 c-addr1 u1 -- ud2 c-addr2 u2 ) \ core to-number
       \G Attempt to convert the character string @var{c-addr1 u1} to an
       \G unsigned number in the current number base. The double
       \G @var{ud1} accumulates the result of the conversion to form
       \G @var{ud2}. Conversion continues, left-to-right, until the whole
       \G string is converted or a character that is not convertable in
       \G the current number base is encountered (including + or -). For
       \G each convertable character, @var{ud1} is first multiplied by
       \G the value in @code{BASE} and then incremented by the value
       \G represented by the character. @var{c-addr2} is the location of
       \G the first unconverted character (past the end of the string if
       \G the whole string was converted). @var{u2} is the number of
       \G unconverted characters in the string. Overflow is not detected.
     0      0
     ?DO      ?DO
         count digit?          count digit?
Line 164 
Line 211 
     um/mod r> ;      um/mod r> ;
   
 \ catch throw                                          23feb93py  \ catch throw                                          23feb93py
 \ bounce                                                08jun93jaw  
   
 \ !! allow the user to add rollback actions    anton  
 \ !! use a separate exception stack?           anton  
   
 has? glocals [IF]  has? glocals [IF]
 : lp@ ( -- addr ) \ gforth      l-p-fetch  : lp@ ( -- addr ) \ gforth      lp-fetch
  laddr# [ 0 , ] ;   laddr# [ 0 , ] ;
 [THEN]  [THEN]
   
 \- 'catch Defer 'catch  defer catch ( x1 .. xn xt -- y1 .. ym 0 / z1 .. zn error ) \ exception
 \- 'throw Defer 'throw  \G @code{Executes} @i{xt}.  If execution returns normally,
   \G @code{catch} pushes 0 on the stack.  If execution returns through
 ' noop IS 'catch  \G @code{throw}, all the stacks are reset to the depth on entry to
 ' noop IS 'throw  \G @code{catch}, and the TOS (the @i{xt} position) is replaced with
   \G the throw code.
 : catch ( x1 .. xn xt -- y1 .. ym 0 / z1 .. zn error ) \ exception  
     'catch  :noname ( ... xt -- ... 0 )
     sp@ >r      execute 0 ;
 [ has? floating [IF] ]  is catch
     fp@ >r  
 [ [THEN] ]  defer throw ( y1 .. ym nerror -- y1 .. ym / z1 .. zn error ) \ exception
 [ has? glocals [IF] ]  \G If @i{nerror} is 0, drop it and continue.  Otherwise, transfer
     lp@ >r  \G control to the next dynamically enclosing exception handler, reset
 [ [THEN] ]  \G the stacks accordingly, and push @i{nerror}.
     handler @ >r  
     rp@ handler !  :noname ( y1 .. ym error -- y1 .. ym / z1 .. zn error )
     execute      ?dup if
     r> handler ! rdrop          [ has? header [IF] here image-header 9 cells + ! [THEN] ]
 [ has? floating [IF] ]          cr .error cr
     rdrop          [ has? file [IF] ] script? IF  1 (bye)  ELSE  quit  THEN
 [ [THEN] ]          [ [ELSE] ] quit [ [THEN] ]
 [ has? glocals [IF] ]      then ;
     rdrop  is throw
 [ [THEN] ]  
     0 ;  
   
 : throw ( y1 .. ym error/0 -- y1 .. ym / z1 .. zn error ) \ exception  
     ?DUP IF  
         [ has? header [IF] here 9 cells ! [THEN] ] ] \ entry point for signal handler  
 [ has? interpreter [IF] ]  
         handler @ dup 0= IF  
 [ has? os [IF] ]  
             2 (bye)  
 [ [ELSE] ]  
             quit  
 [ [THEN] ]  
         THEN  
 [ [THEN] ]  
         rp!  
         r> handler !  
 [ has? glocals [IF] ]  
         r> lp!  
 [ [THEN] ]  
 [ has? floating [IF] ]  
         r> fp!  
 [ [THEN] ]  
         r> swap >r sp! drop r>  
         'throw  
     THEN ;  
   
 \ Bouncing is very fine,  
 \ programming without wasting time...   jaw  
 : bounce ( y1 .. ym error/0 -- y1 .. ym error / y1 .. ym ) \ gforth  
 \ a throw without data or fp stack restauration  
   ?DUP IF  
       handler @ rp!  
       r> handler !  
 [ has? glocals [IF] ]  
       r> lp!  
 [ [THEN] ]  
 [ has? floating [IF] ]  
       rdrop  
 [ [THEN] ]  
       rdrop  
       'throw  
   THEN ;  
   
 \ (abort")  \ (abort")
   
   : c(abort") ( c-addr -- )
       "error ! -2 throw ;
   
 : (abort")  : (abort")
     "lit >r      "lit >r
     IF      IF
Line 251 
Line 254 
     THEN      THEN
     rdrop ;      rdrop ;
   
   : abort ( ?? -- ?? ) \ core,exception-ext
       \G @code{-1 throw}.
       -1 throw ;
   
 \ ?stack                                               23feb93py  \ ?stack                                               23feb93py
   
 : ?stack ( ?? -- ?? ) \ gforth  : ?stack ( ?? -- ?? ) \ gforth
Line 263 
Line 270 
   
 \ DEPTH                                                 9may93jaw  \ DEPTH                                                 9may93jaw
   
 : depth ( -- +n ) \ core  : depth ( -- +n ) \ core depth
       \G @var{+n} is the number of values that were on the data stack before
       \G @var{+n} itself was placed on the stack.
     sp@ sp0 @ swap - cell / ;      sp@ sp0 @ swap - cell / ;
 : clearstack ( ... -- )  
   : clearstack ( ... -- ) \ gforth clear-stack
       \G remove and discard all/any items from the data stack.
     sp0 @ sp! ;      sp0 @ sp! ;
   
 \ Strings                                                22feb93py  \ Strings                                                22feb93py
Line 277 
Line 288 
   
 \ !! I think */mod should have the same rounding behaviour as / - anton  \ !! I think */mod should have the same rounding behaviour as / - anton
 : */mod ( n1 n2 n3 -- n4 n5 ) \ core    star-slash-mod  : */mod ( n1 n2 n3 -- n4 n5 ) \ core    star-slash-mod
       \G n1*n2=n3*n5+n4, with the intermediate result (n1*n2) being double.
     >r m* r> sm/rem ;      >r m* r> sm/rem ;
   
 : */ ( n1 n2 n3 -- n4 ) \ core  star-slash  : */ ( n1 n2 n3 -- n4 ) \ core  star-slash
       \G n4=(n1*n2)/n3, with the intermediate result being double.
     */mod nip ;      */mod nip ;
   
 \ HEX DECIMAL                                           2may93jaw  \ HEX DECIMAL                                           2may93jaw
   
 : decimal ( -- ) \ core  : decimal ( -- ) \ core
       \G Set @code{base} to &10 (decimal).
     a base ! ;      a base ! ;
 : hex ( -- ) \ core-ext  : hex ( -- ) \ core-ext
       \G Set @code{base} to &16 (hexadecimal).
     10 base ! ;      10 base ! ;
   

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

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help