Return to basics.fs CVS log

Up to [gforth] / gforth / kernel

Added section talking about different memory regions, and glossed
associated words. Glossed words associated with user input; the
manual still needs a bunch of examples for these.

    1: \ kernel.fs    GForth kernel                        17dec92py
    2: 
    3: \ Copyright (C) 1995,1998 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 2
   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, write to the Free Software
   19: \ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
   20: 
   21: \ Idea and implementation: Bernd Paysan (py)
   22: 
   23: HEX
   24: 
   25: \ labels for some code addresses
   26: 
   27: \- NIL NIL AConstant NIL \ gforth
   28: 
   29: \ Aliases
   30: 
   31: [IFUNDEF] r@
   32: ' i Alias r@ ( -- w ; R: w -- w ) \ core r-fetch
   33: \G Copy @var{w} from the return stack to the data stack.
   34: [THEN]
   35: 
   36: \ !! this is machine-dependent, but works on all but the strangest machines
   37: 
   38: : maxaligned ( addr -- f-addr ) \ gforth
   39:     [ /maxalign 1 - ] Literal + [ 0 /maxalign - ] Literal and ;
   40: \ !! machine-dependent and won't work if "0 >body" <> "0 >body maxaligned"
   41: ' maxaligned Alias cfaligned ( addr1 -- addr2 ) \ gforth
   42: 
   43: : chars ( n1 -- n2 ) \ core
   44: ; immediate
   45: 
   46: 
   47: \ : A!    ( addr1 addr2 -- ) \ gforth
   48: \    dup relon ! ;
   49: \ : A,    ( addr -- ) \ gforth
   50: \    here cell allot A! ;
   51: ' ! alias A! ( addr1 addr2 -- ) \ gforth
   52: 
   53: \ UNUSED                                                17may93jaw
   54: 
   55: has? ec 
   56: [IF]
   57: unlock ram-dictionary area nip lock
   58: Constant dictionary-end
   59: [ELSE]
   60: : dictionary-end ( -- addr )
   61:     forthstart [ 3 cells ] Aliteral @ + ;
   62: [THEN]
   63: 
   64: : unused ( -- u ) \ core-ext
   65:     \G Return the amount of free space remaining (in address units) in
   66:     \G the region addressed by @code{here}.
   67:     dictionary-end here - [ word-pno-size pad-minsize + ] Literal - ;
   68: 
   69: \ here is used for pad calculation!
   70: 
   71: : dp    ( -- addr ) \ gforth
   72:     dpp @ ;
   73: : here  ( -- addr ) \ core
   74:     \G Return the address of the next free location in data space.
   75:     dp @ ;
   76: 
   77: \ on off                                               23feb93py
   78: 
   79: \ on is used by docol:
   80: : on  ( addr -- ) \ gforth
   81:     true  swap ! ;
   82: : off ( addr -- ) \ gforth
   83:     false swap ! ;
   84: 
   85: \ dabs roll                                           17may93jaw
   86: 
   87: : dabs ( d1 -- d2 ) \ double
   88:     dup 0< IF dnegate THEN ;
   89: 
   90: : roll  ( x0 x1 .. xn n -- x1 .. xn x0 ) \ core-ext
   91:   dup 1+ pick >r
   92:   cells sp@ cell+ dup cell+ rot move drop r> ;
   93: 
   94: \ place bounds                                         13feb93py
   95: 
   96: : place  ( addr len to -- ) \ gforth
   97:     over >r  rot over 1+  r> move c! ;
   98: : bounds ( beg count -- end beg ) \ gforth
   99:     over + swap ;
  100: 
  101: \ (word)                                               22feb93py
  102: 
  103: : scan   ( addr1 n1 char -- addr2 n2 ) \ gforth
  104:     \ skip all characters not equal to char
  105:     >r
  106:     BEGIN
  107: 	dup
  108:     WHILE
  109: 	over c@ r@ <>
  110:     WHILE
  111: 	1 /string
  112:     REPEAT  THEN
  113:     rdrop ;
  114: : skip   ( addr1 n1 char -- addr2 n2 ) \ gforth
  115:     \ skip all characters equal to char
  116:     >r
  117:     BEGIN
  118: 	dup
  119:     WHILE
  120: 	over c@ r@  =
  121:     WHILE
  122: 	1 /string
  123:     REPEAT  THEN
  124:     rdrop ;
  125: 
  126: \ digit?                                               17dec92py
  127: 
  128: : digit?   ( char -- digit true/ false ) \ gforth
  129:   base @ $100 =
  130:   IF
  131:     true EXIT
  132:   THEN
  133:   toupper [char] 0 - dup 9 u> IF
  134:     [ 'A '9 1 + -  ] literal -
  135:     dup 9 u<= IF
  136:       drop false EXIT
  137:     THEN
  138:   THEN
  139:   dup base @ u>= IF
  140:     drop false EXIT
  141:   THEN
  142:   true ;
  143: 
  144: : accumulate ( +d0 addr digit - +d1 addr )
  145:   swap >r swap  base @  um* drop rot  base @  um* d+ r> ;
  146: 
  147: : >number ( ud1 c-addr1 u1 -- ud2 c-addr2 u2 ) \ core
  148:     \G Attempt to convert the character string @var{c-addr1, u1} to an
  149:     \G unsigned number in the current number base. The double
  150:     \G @var{ud1} accumulates the result of the conversion to form
  151:     \G @var{ud2}. Conversion continues, left-to-right, until the whole
  152:     \G string is converted or a character that is not convertable in
  153:     \G the current number base is encountered (including + or -). For
  154:     \G each convertable character, @var{ud1} is first multiplied by
  155:     \G the value in @code{BASE} and then incremented by the value
  156:     \G represented by the character. @var{c-addr2} is the location of
  157:     \G the first unconverted character (past the end of the string if
  158:     \G the whole string was converted). @var{u2} is the number of
  159:     \G unconverted characters in the string. Overflow is not detected.
  160:     0
  161:     ?DO
  162: 	count digit?
  163:     WHILE
  164: 	accumulate
  165:     LOOP
  166:         0
  167:     ELSE
  168: 	1- I' I -
  169: 	UNLOOP
  170:     THEN ;
  171: 
  172: \ s>d um/mod						21mar93py
  173: 
  174: : s>d ( n -- d ) \ core		s-to-d
  175:     dup 0< ;
  176: 
  177: : ud/mod ( ud1 u2 -- urem udquot ) \ gforth
  178:     >r 0 r@ um/mod r> swap >r
  179:     um/mod r> ;
  180: 
  181: \ catch throw                                          23feb93py
  182: \ bounce                                                08jun93jaw
  183: 
  184: \ !! allow the user to add rollback actions    anton
  185: \ !! use a separate exception stack?           anton
  186: 
  187: has? glocals [IF]
  188: : lp@ ( -- addr ) \ gforth	lp-fetch
  189:  laddr# [ 0 , ] ;
  190: [THEN]
  191: 
  192: \- 'catch Defer 'catch
  193: \- 'throw Defer 'throw
  194: 
  195: ' noop IS 'catch
  196: ' noop IS 'throw
  197: 
  198: Defer store-backtrace
  199: ' noop IS store-backtrace
  200: 
  201: : catch ( x1 .. xn xt -- y1 .. ym 0 / z1 .. zn error ) \ exception
  202:     'catch
  203:     sp@ >r
  204: [ has? floating [IF] ]
  205:     fp@ >r
  206: [ [THEN] ]
  207: [ has? glocals [IF] ]
  208:     lp@ >r
  209: [ [THEN] ]
  210:     handler @ >r
  211:     rp@ handler !
  212:     backtrace-empty on
  213:     execute
  214:     r> handler ! rdrop 
  215: [ has? floating [IF] ]
  216:     rdrop
  217: [ [THEN] ]
  218: [ has? glocals [IF] ]
  219:     rdrop
  220: [ [THEN] ]
  221:     0 ;
  222: 
  223: : throw ( y1 .. ym error/0 -- y1 .. ym / z1 .. zn error ) \ exception
  224:     ?DUP IF
  225: 	[ has? header [IF] here 9 cells ! [THEN] ] \ entry point for signal handler
  226: 	store-backtrace
  227: [ has? interpreter [IF] ]
  228: 	handler @ dup 0= IF
  229: [ has? os [IF] ]
  230: 	    2 (bye)
  231: [ [ELSE] ]
  232: 	    quit
  233: [ [THEN] ]
  234: 	THEN
  235: [ [THEN] ]
  236: 	rp!
  237: 	r> handler !
  238: [ has? glocals [IF] ]
  239:         r> lp!
  240: [ [THEN] ]
  241: [ has? floating [IF] ]
  242: 	r> fp!
  243: [ [THEN] ]
  244: 	r> swap >r sp! drop r>
  245: 	'throw
  246:     THEN ;
  247: 
  248: \ Bouncing is very fine,
  249: \ programming without wasting time...   jaw
  250: : bounce ( y1 .. ym error/0 -- y1 .. ym error / y1 .. ym ) \ gforth
  251: \ a throw without data or fp stack restauration
  252:   ?DUP IF
  253:       store-backtrace
  254:       handler @ rp!
  255:       r> handler !
  256: [ has? glocals [IF] ]
  257:       r> lp!
  258: [ [THEN] ]
  259: [ has? floating [IF] ]
  260:       rdrop
  261: [ [THEN] ]
  262:       rdrop
  263:       'throw
  264:   THEN ;
  265: 
  266: \ (abort")
  267: 
  268: : (abort")
  269:     "lit >r
  270:     IF
  271: 	r> "error ! -2 throw
  272:     THEN
  273:     rdrop ;
  274: 
  275: : abort ( ?? -- ?? ) \ core,exception-ext
  276:     \G Empty the data stack and perform the functions of @code{quit}.
  277:     \G Since the exception word set is present, this is performed by
  278:     \G @code{-1 throw}.
  279:     -1 throw ;
  280: 
  281: \ ?stack                                               23feb93py
  282: 
  283: : ?stack ( ?? -- ?? ) \ gforth
  284:     sp@ sp0 @ u> IF    -4 throw  THEN
  285: [ has? floating [IF] ]
  286:     fp@ fp0 @ u> IF  -&45 throw  THEN
  287: [ [THEN] ]
  288: ;
  289: \ ?stack should be code -- it touches an empty stack!
  290: 
  291: \ DEPTH                                                 9may93jaw
  292: 
  293: : depth ( -- +n ) \ core depth
  294:     \G @var{+n} is the number of values that were on the data stack before
  295:     \G @var{+n} itself was placed on the stack.
  296:     sp@ sp0 @ swap - cell / ;
  297: 
  298: : clearstack ( ... -- ) \ gforth clear-stack
  299:     \G remove and discard all/any items from the data stack.
  300:     sp0 @ sp! ;
  301: 
  302: \ Strings						 22feb93py
  303: 
  304: : "lit ( -- addr )
  305:   r> r> dup count + aligned >r swap >r ;
  306: 
  307: \ */MOD */                                              17may93jaw
  308: 
  309: \ !! I think */mod should have the same rounding behaviour as / - anton
  310: : */mod ( n1 n2 n3 -- n4 n5 ) \ core	star-slash-mod
  311:     >r m* r> sm/rem ;
  312: 
  313: : */ ( n1 n2 n3 -- n4 ) \ core	star-slash
  314:     */mod nip ;
  315: 
  316: \ HEX DECIMAL                                           2may93jaw
  317: 
  318: : decimal ( -- ) \ core
  319:     \G Set the numeric conversion radix (the value of @code{BASE}) to 10
  320:     \G (decimal).
  321:     a base ! ;
  322: : hex ( -- ) \ core-ext
  323:     \G Set the numeric conversion radix (the value of @code{BASE}) to 16
  324:     \G (hexadecimal).
  325:     10 base ! ;
  326: