File:  [gforth] / gforth / kernel / basics.fs
Revision 1.15: download - view: text, annotated - select for diffs
Thu May 6 21:33:36 1999 UTC (24 years, 10 months ago) by crook
Branches: MAIN
CVS tags: HEAD
Major re-write of manual sections concerning text interpreter and
defining words. Much fine-tuning of other sections. The manual is
``nearly finished'' -- at least, all the major pieces of work that
I envisaged for the first mods (which were only going to take a
couple of weeks...). The manual has grown from 127 pages to 192
which is good news in terms of content but bad news in terms of the
time it takes to print out on my HP550C DeskJet.

Other changes are just tweaks to glossary entries.

\ kernel.fs    GForth kernel                        17dec92py

\ Copyright (C) 1995,1998 Free Software Foundation, Inc.

\ This file is part of Gforth.

\ Gforth is free software; you can redistribute it and/or
\ modify it under the terms of the GNU General Public License
\ as published by the Free Software Foundation; either version 2
\ of the License, or (at your option) any later version.

\ This program is distributed in the hope that it will be useful,
\ but WITHOUT ANY WARRANTY; without even the implied warranty of
\ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
\ GNU General Public License for more details.

\ You should have received a copy of the GNU General Public License
\ along with this program; if not, write to the Free Software
\ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.

\ Idea and implementation: Bernd Paysan (py)

HEX

\ labels for some code addresses

\- NIL NIL AConstant NIL \ gforth

\ Aliases

[IFUNDEF] r@
' i Alias r@ ( -- w ; R: w -- w ) \ core r-fetch
\G Copy @var{w} from the return stack to the data stack.
[THEN]

\ !! this is machine-dependent, but works on all but the strangest machines

: maxaligned ( addr -- f-addr ) \ gforth
    [ /maxalign 1 - ] Literal + [ 0 /maxalign - ] Literal and ;
\ !! machine-dependent and won't work if "0 >body" <> "0 >body maxaligned"
' maxaligned Alias cfaligned ( addr1 -- addr2 ) \ gforth

: chars ( n1 -- n2 ) \ core
\G @i{n2} is the number of address units corresponding to @i{n1} chars.""
; immediate


\ : A!    ( addr1 addr2 -- ) \ gforth
\    dup relon ! ;
\ : A,    ( addr -- ) \ gforth
\    here cell allot A! ;
' ! alias A! ( addr1 addr2 -- ) \ gforth

\ UNUSED                                                17may93jaw

has? ec 
[IF]
unlock ram-dictionary area nip lock
Constant dictionary-end
[ELSE]
: dictionary-end ( -- addr )
    forthstart [ 3 cells ] Aliteral @ + ;
[THEN]

: usable-dictionary-end ( -- addr )
    dictionary-end [ word-pno-size pad-minsize + ] Literal - ;

: unused ( -- u ) \ core-ext
    \G Return the amount of free space remaining (in address units) in
    \G the region addressed by @code{here}.
    usable-dictionary-end here - ;

\ here is used for pad calculation!

: dp    ( -- addr ) \ gforth
    dpp @ ;
: here  ( -- addr ) \ core
    \G Return the address of the next free location in data space.
    dp @ ;

\ on off                                               23feb93py

\ on is used by docol:
: on  ( a-addr -- ) \ gforth
    \G Set the (value of the) variable  at @i{a-addr} to @code{true}.
    true  swap ! ;
: off ( a-addr -- ) \ gforth
    \G Set the (value of the) variable at @i{a-addr} to @code{false}.
    false swap ! ;

\ dabs roll                                           17may93jaw

: dabs ( d1 -- d2 ) \ double
    dup 0< IF dnegate THEN ;

: roll  ( x0 x1 .. xn n -- x1 .. xn x0 ) \ core-ext
  dup 1+ pick >r
  cells sp@ cell+ dup cell+ rot move drop r> ;

\ place bounds                                         13feb93py

: place  ( addr len to -- ) \ gforth
    over >r  rot over 1+  r> move c! ;
: bounds ( beg count -- end beg ) \ gforth
    over + swap ;

\ (word)                                               22feb93py

: scan   ( addr1 n1 char -- addr2 n2 ) \ gforth
    \ skip all characters not equal to char
    >r
    BEGIN
	dup
    WHILE
	over c@ r@ <>
    WHILE
	1 /string
    REPEAT  THEN
    rdrop ;
: skip   ( addr1 n1 char -- addr2 n2 ) \ gforth
    \ skip all characters equal to char
    >r
    BEGIN
	dup
    WHILE
	over c@ r@  =
    WHILE
	1 /string
    REPEAT  THEN
    rdrop ;

\ digit?                                               17dec92py

: digit?   ( char -- digit true/ false ) \ gforth
  base @ $100 =
  IF
    true EXIT
  THEN
  toupper [char] 0 - dup 9 u> IF
    [ 'A '9 1 + -  ] literal -
    dup 9 u<= IF
      drop false EXIT
    THEN
  THEN
  dup base @ u>= IF
    drop false EXIT
  THEN
  true ;

: accumulate ( +d0 addr digit - +d1 addr )
  swap >r swap  base @  um* drop rot  base @  um* d+ r> ;

: >number ( ud1 c-addr1 u1 -- ud2 c-addr2 u2 ) \ core
    \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
    ?DO
	count digit?
    WHILE
	accumulate
    LOOP
        0
    ELSE
	1- I' I -
	UNLOOP
    THEN ;

\ s>d um/mod						21mar93py

: s>d ( n -- d ) \ core		s-to-d
    dup 0< ;

: ud/mod ( ud1 u2 -- urem udquot ) \ gforth
    >r 0 r@ um/mod r> swap >r
    um/mod r> ;

\ catch throw                                          23feb93py
\ bounce                                                08jun93jaw

\ !! allow the user to add rollback actions    anton
\ !! use a separate exception stack?           anton

has? glocals [IF]
: lp@ ( -- addr ) \ gforth	lp-fetch
 laddr# [ 0 , ] ;
[THEN]

\- 'catch Defer 'catch
\- 'throw Defer 'throw

' noop IS 'catch
' noop IS 'throw

Defer store-backtrace
' noop IS store-backtrace

: catch ( x1 .. xn xt -- y1 .. ym 0 / z1 .. zn error ) \ exception
    'catch
    sp@ >r
[ has? floating [IF] ]
    fp@ >r
[ [THEN] ]
[ has? glocals [IF] ]
    lp@ >r
[ [THEN] ]
    handler @ >r
    rp@ handler !
    backtrace-empty on
    execute
    r> handler ! rdrop 
[ has? floating [IF] ]
    rdrop
[ [THEN] ]
[ has? glocals [IF] ]
    rdrop
[ [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
	store-backtrace
[ 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
      store-backtrace
      handler @ rp!
      r> handler !
[ has? glocals [IF] ]
      r> lp!
[ [THEN] ]
[ has? floating [IF] ]
      rdrop
[ [THEN] ]
      rdrop
      'throw
  THEN ;

\ (abort")

: (abort")
    "lit >r
    IF
	r> "error ! -2 throw
    THEN
    rdrop ;

: abort ( ?? -- ?? ) \ core,exception-ext
    \G Empty the data stack and perform the functions of @code{quit}.
    \G Since the exception word set is present, this is performed by
    \G @code{-1 throw}.
    -1 throw ;

\ ?stack                                               23feb93py

: ?stack ( ?? -- ?? ) \ gforth
    sp@ sp0 @ u> IF    -4 throw  THEN
[ has? floating [IF] ]
    fp@ fp0 @ u> IF  -&45 throw  THEN
[ [THEN] ]
;
\ ?stack should be code -- it touches an empty stack!

\ DEPTH                                                 9may93jaw

: 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 / ;

: clearstack ( ... -- ) \ gforth clear-stack
    \G remove and discard all/any items from the data stack.
    sp0 @ sp! ;

\ Strings						 22feb93py

: "lit ( -- addr )
  r> r> dup count + aligned >r swap >r ;

\ */MOD */                                              17may93jaw

\ !! I think */mod should have the same rounding behaviour as / - anton
: */mod ( n1 n2 n3 -- n4 n5 ) \ core	star-slash-mod
    >r m* r> sm/rem ;

: */ ( n1 n2 n3 -- n4 ) \ core	star-slash
    */mod nip ;

\ HEX DECIMAL                                           2may93jaw

: decimal ( -- ) \ core
    \G Set the numeric conversion radix (the value of @code{BASE}) to 10
    \G (decimal).
    a base ! ;
: hex ( -- ) \ core-ext
    \G Set the numeric conversion radix (the value of @code{BASE}) to 16
    \G (hexadecimal).
    10 base ! ;


FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>