File:  [gforth] / gforth / kernel / basics.fs
Revision 1.68: download - view: text, annotated - select for diffs
Sat Dec 31 15:29:26 2011 UTC (12 years, 2 months ago) by anton
Branches: MAIN
CVS tags: HEAD
updated copyright years

    1: \ kernel.fs    GForth kernel                        17dec92py
    2: 
    3: \ Copyright (C) 1995,1998,2000,2003,2004,2005,2006,2007,2008,2010,2011 Free Software Foundation, Inc.
    4: 
    5: \ This file is part of Gforth.
    6: 
    7: \ Gforth is free software; you can redistribute it and/or
    8: \ modify it under the terms of the GNU General Public License
    9: \ as published by the Free Software Foundation, either version 3
   10: \ of the License, or (at your option) any later version.
   11: 
   12: \ This program is distributed in the hope that it will be useful,
   13: \ but WITHOUT ANY WARRANTY; without even the implied warranty of
   14: \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
   15: \ GNU General Public License for more details.
   16: 
   17: \ You should have received a copy of the GNU General Public License
   18: \ along with this program. If not, see http://www.gnu.org/licenses/.
   19: 
   20: \ Idea and implementation: Bernd Paysan (py)
   21: 
   22: \ Needs:
   23: 
   24: require ./vars.fs
   25: require ../compat/strcomp.fs
   26: 
   27: hex
   28: 
   29: \ labels for some code addresses
   30: 
   31: \- NIL NIL AConstant NIL \ gforth
   32: 
   33: \ Aliases
   34: 
   35: [IFUNDEF] r@
   36: ' i Alias r@ ( -- w ; R: w -- w ) \ core r-fetch
   37: [THEN]
   38: 
   39: \ !! this is machine-dependent, but works on all but the strangest machines
   40: 
   41: : maxaligned ( addr1 -- addr2 ) \ gforth
   42:     \G @i{addr2} is the first address after @i{addr1} that satisfies
   43:     \G all alignment restrictions.
   44:     [ /maxalign 1 - ] Literal + [ 0 /maxalign - ] Literal and ;
   45: \ !! machine-dependent and won't work if "0 >body" <> "0 >body
   46:     \G maxaligned"
   47: ' maxaligned Alias cfaligned ( addr1 -- addr2 ) \ gforth
   48: \G @i{addr2} is the first address after @i{addr1} that is aligned for
   49: \G a code field (i.e., such that the corresponding body is maxaligned).
   50: 
   51: : chars ( n1 -- n2 ) \ core
   52: \G @i{n2} is the number of address units of @i{n1} chars.""
   53: ; immediate
   54: 
   55: 
   56: \ : A!    ( addr1 addr2 -- ) \ gforth
   57: \    dup relon ! ;
   58: \ : A,    ( addr -- ) \ gforth
   59: \    here cell allot A! ;
   60: ' ! alias A! ( addr1 addr2 -- ) \ gforth
   61: 
   62: \ UNUSED                                                17may93jaw
   63: 
   64: has? ec [IF]
   65: unlock ram-dictionary borders nip lock
   66: AConstant dictionary-end
   67: [ELSE]
   68:     has? header [IF]
   69: 	: dictionary-end ( -- addr )
   70: 	    forthstart [ 3 cells image-header + ] Aliteral @ + ;
   71:     [ELSE]
   72: 	: forthstart 0 ;
   73: 	: dictionary-end ( -- addr )
   74: 	    forthstart [ has? kernel-size ] Literal + ;
   75:     [THEN]
   76: [THEN]
   77: 
   78: : usable-dictionary-end1 ( -- addr )
   79:     dictionary-end [ word-pno-size pad-minsize + ] Literal - ;
   80: 
   81: defer usable-dictionary-end ( -- addr )
   82: ' usable-dictionary-end1 is usable-dictionary-end
   83: 
   84: : unused ( -- u ) \ core-ext
   85:     \G Return the amount of free space remaining (in address units) in
   86:     \G the region addressed by @code{here}.
   87:     usable-dictionary-end here - ;
   88: 
   89: has? ec has? primcentric 0= and [IF]
   90: : in-dictionary? ( x -- f )
   91:     dictionary-end u< ;
   92: [ELSE]    
   93: : in-dictionary? ( x -- f )
   94:     forthstart dictionary-end within ;
   95: [THEN]
   96: 
   97: \ here is used for pad calculation!
   98: 
   99: : dp    ( -- addr ) \ gforth
  100:     dpp @ ;
  101: : here  ( -- addr ) \ core
  102:     \G Return the address of the next free location in data space.
  103:     dp @ ;
  104: 
  105: \ on off                                               23feb93py
  106: 
  107: \ on is used by docol:
  108: : on  ( a-addr -- ) \ gforth
  109:     \G Set the (value of the) variable  at @i{a-addr} to @code{true}.
  110:     true  swap ! ;
  111: : off ( a-addr -- ) \ gforth
  112:     \G Set the (value of the) variable at @i{a-addr} to @code{false}.
  113:     false swap ! ;
  114: 
  115: \ dabs roll                                           17may93jaw
  116: 
  117: : dabs ( d -- ud ) \ double d-abs
  118:     dup 0< IF dnegate THEN ;
  119: 
  120: : roll  ( x0 x1 .. xn n -- x1 .. xn x0 ) \ core-ext
  121:     \  dup 1+ pick >r
  122:     \  cells sp@ cell+ dup cell+ rot move drop r> ;
  123:     dup 0<= if
  124: 	drop
  125:     else
  126: 	swap >r 1- recurse r> swap 
  127:     then ;
  128: 
  129: \ place bounds                                         13feb93py
  130: 
  131: : place  ( addr len to -- ) \ gforth
  132:     over >r  rot over 1+  r> move c! ;
  133: : bounds ( addr u -- addr+u addr ) \ gforth
  134:     \G Given a memory block represented by starting address @i{addr}
  135:     \G and length @i{u} in aus, produce the end address @i{addr+u} and
  136:     \G the start address in the right order for @code{u+do} or
  137:     \G @code{?do}.
  138:     over + swap ;
  139: 
  140: \ (word)                                               22feb93py
  141: 
  142: : scan   ( addr1 n1 char -- addr2 n2 ) \ gforth
  143:     \G skip all characters not equal to char
  144:     >r
  145:     BEGIN
  146: 	dup
  147:     WHILE
  148: 	over c@ r@ <>
  149:     WHILE
  150: 	1 /string
  151:     REPEAT  THEN
  152:     rdrop ;
  153: : skip   ( addr1 n1 char -- addr2 n2 ) \ gforth
  154:     \G skip all characters equal to char
  155:     >r
  156:     BEGIN
  157: 	dup
  158:     WHILE
  159: 	over c@ r@  =
  160:     WHILE
  161: 	1 /string
  162:     REPEAT  THEN
  163:     rdrop ;
  164: 
  165: \ digit?                                               17dec92py
  166: 
  167: : digit?   ( char -- digit true/ false ) \ gforth
  168:   toupper [char] 0 - dup 9 u> IF
  169:     [ char A char 9 1 + -  ] literal -
  170:     dup 9 u<= IF
  171:       drop false EXIT
  172:     THEN
  173:   THEN
  174:   dup base @ u>= IF
  175:     drop false EXIT
  176:   THEN
  177:   true ;
  178: 
  179: : accumulate ( +d0 addr digit - +d1 addr )
  180:   swap >r swap  base @  um* drop rot  base @  um* d+ r> ;
  181: 
  182: : >number ( ud1 c-addr1 u1 -- ud2 c-addr2 u2 ) \ core to-number
  183:     \G Attempt to convert the character string @var{c-addr1 u1} to an
  184:     \G unsigned number in the current number base. The double
  185:     \G @var{ud1} accumulates the result of the conversion to form
  186:     \G @var{ud2}. Conversion continues, left-to-right, until the whole
  187:     \G string is converted or a character that is not convertable in
  188:     \G the current number base is encountered (including + or -). For
  189:     \G each convertable character, @var{ud1} is first multiplied by
  190:     \G the value in @code{BASE} and then incremented by the value
  191:     \G represented by the character. @var{c-addr2} is the location of
  192:     \G the first unconverted character (past the end of the string if
  193:     \G the whole string was converted). @var{u2} is the number of
  194:     \G unconverted characters in the string. Overflow is not detected.
  195:     0
  196:     ?DO
  197: 	count digit?
  198:     WHILE
  199: 	accumulate
  200:     LOOP
  201:         0
  202:     ELSE
  203: 	1- I' I -
  204: 	UNLOOP
  205:     THEN ;
  206: 
  207: \ s>d um/mod						21mar93py
  208: 
  209: : s>d ( n -- d ) \ core		s-to-d
  210:     dup 0< ;
  211: 
  212: : ud/mod ( ud1 u2 -- urem udquot ) \ gforth
  213:     >r 0 r@ um/mod r> swap >r
  214:     um/mod r> ;
  215: 
  216: \ catch throw                                          23feb93py
  217: 
  218: has? glocals [IF]
  219: : lp@ ( -- addr ) \ gforth	lp-fetch
  220:  laddr# [ 0 , ] ;
  221: [THEN]
  222: 
  223: has? os 0= [IF]
  224:     : catch  ( ... xt -- ... 0 )
  225: 	handler @ >r sp@ >r
  226: 	rp@ handler ! execute 0 r> drop r> handler ! ;
  227:     : throw  ( error -- error )  dup 0= IF  drop EXIT  THEN
  228: 	handler @ rp! r> swap >r sp! r> r> handler ! ;
  229: [ELSE]
  230: defer catch ( x1 .. xn xt -- y1 .. ym 0 / z1 .. zn error ) \ exception
  231: \G @code{Executes} @i{xt}.  If execution returns normally,
  232: \G @code{catch} pushes 0 on the stack.  If execution returns through
  233: \G @code{throw}, all the stacks are reset to the depth on entry to
  234: \G @code{catch}, and the TOS (the @i{xt} position) is replaced with
  235: \G the throw code.
  236: 
  237: :noname ( ... xt -- ... 0 )
  238:     execute 0 ;
  239: is catch
  240: 
  241: defer throw ( y1 .. ym nerror -- y1 .. ym / z1 .. zn error ) \ exception
  242: \G If @i{nerror} is 0, drop it and continue.  Otherwise, transfer
  243: \G control to the next dynamically enclosing exception handler, reset
  244: \G the stacks accordingly, and push @i{nerror}.
  245: 
  246: :noname ( y1 .. ym error -- y1 .. ym / z1 .. zn error )
  247:     ?dup if
  248: 	[ has? header [IF] here image-header 9 cells + ! [THEN] ]
  249: 	cr DoError cr
  250: 	[ has? file [IF] ] script? IF  1 (bye)  ELSE  quit  THEN
  251: 	[ [ELSE] ] quit [ [THEN] ]
  252:     then ;
  253: is throw
  254: [THEN]
  255: 
  256: \ (abort")
  257: 
  258: : c(abort") ( c-addr -- )
  259:     "error ! -2 throw ;
  260: 
  261: : (abort")
  262:     "lit >r
  263:     IF
  264: 	r> "error ! -2 throw
  265:     THEN
  266:     rdrop ;
  267: 
  268: : abort ( ?? -- ?? ) \ core,exception-ext
  269:     \G @code{-1 throw}.
  270:     -1 throw ;
  271: 
  272: \ ?stack                                               23feb93py
  273: 
  274: : ?stack ( ?? -- ?? ) \ gforth
  275:     sp@ sp0 @ u> IF    -4 throw  THEN
  276: [ has? floating [IF] ]
  277:     fp@ fp0 @ u> IF  -&45 throw  THEN
  278: [ [THEN] ]
  279: ;
  280: \ ?stack should be code -- it touches an empty stack!
  281: 
  282: \ DEPTH                                                 9may93jaw
  283: 
  284: : depth ( -- +n ) \ core depth
  285:     \G @var{+n} is the number of values that were on the data stack before
  286:     \G @var{+n} itself was placed on the stack.
  287:     sp@ sp0 @ swap - cell / ;
  288: 
  289: : clearstack ( ... -- ) \ gforth clear-stack
  290: \G remove and discard all/any items from the data stack.
  291:     sp0 @ sp! ;
  292: 
  293: : clearstacks ( ... -- ) \ gforth clear-stacks
  294: \G empty data and FP stack
  295:     clearstack
  296: [ has? floating [IF] ]
  297:     fp0 @ fp!
  298: [ [THEN] ]
  299: ;
  300: 
  301: \ Strings						 22feb93py
  302: 
  303: : "lit ( -- addr )
  304:   r> r> dup count + aligned >r swap >r ;
  305: 
  306: \ HEX DECIMAL                                           2may93jaw
  307: 
  308: : decimal ( -- ) \ core
  309:     \G Set @code{base} to &10 (decimal).  Don't use @code{decimal}, use
  310:     \G @code{base-execute} instead.
  311:     a base ! ;
  312: : hex ( -- ) \ core-ext
  313:     \G Set @code{base} to &16 (hexadecimal).  Don't use @code{hex},
  314:     \G use @code{base-execute} instead.
  315:     10 base ! ;
  316: 

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