File:  [gforth] / gforth / kernel / basics.fs
Revision 1.7: download - view: text, annotated - select for diffs
Tue Dec 8 22:03:08 1998 UTC (23 years, 8 months ago) by anton
Branches: MAIN
CVS tags: v0-4-0, HEAD
updated dates in copyright messages
inserted copyright messages in most files that did not have them
removed outdated files engine/32bit.h engine/strsig.c

    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 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 ) \ float
   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:     dictionary-end here - [ word-pno-size pad-minsize + ] Literal - ;
   66: 
   67: \ here is used for pad calculation!
   68: 
   69: : dp    ( -- addr ) \ gforth
   70:     dpp @ ;
   71: : here  ( -- here ) \ core
   72:     dp @ ;
   73: 
   74: \ on off                                               23feb93py
   75: 
   76: \ on is used by docol:
   77: : on  ( addr -- ) \ gforth
   78:     true  swap ! ;
   79: : off ( addr -- ) \ gforth
   80:     false swap ! ;
   81: 
   82: \ dabs roll                                           17may93jaw
   83: 
   84: : dabs ( d1 -- d2 ) \ double
   85:     dup 0< IF dnegate THEN ;
   86: 
   87: : roll  ( x0 x1 .. xn n -- x1 .. xn x0 ) \ core-ext
   88:   dup 1+ pick >r
   89:   cells sp@ cell+ dup cell+ rot move drop r> ;
   90: 
   91: \ place bounds                                         13feb93py
   92: 
   93: : place  ( addr len to -- ) \ gforth
   94:     over >r  rot over 1+  r> move c! ;
   95: : bounds ( beg count -- end beg ) \ gforth
   96:     over + swap ;
   97: 
   98: \ (word)                                               22feb93py
   99: 
  100: : scan   ( addr1 n1 char -- addr2 n2 ) \ gforth
  101:     \ skip all characters not equal to char
  102:     >r
  103:     BEGIN
  104: 	dup
  105:     WHILE
  106: 	over c@ r@ <>
  107:     WHILE
  108: 	1 /string
  109:     REPEAT  THEN
  110:     rdrop ;
  111: : skip   ( addr1 n1 char -- addr2 n2 ) \ gforth
  112:     \ skip all characters equal to char
  113:     >r
  114:     BEGIN
  115: 	dup
  116:     WHILE
  117: 	over c@ r@  =
  118:     WHILE
  119: 	1 /string
  120:     REPEAT  THEN
  121:     rdrop ;
  122: 
  123: \ digit?                                               17dec92py
  124: 
  125: : digit?   ( char -- digit true/ false ) \ gforth
  126:   base @ $100 =
  127:   IF
  128:     true EXIT
  129:   THEN
  130:   toupper [char] 0 - dup 9 u> IF
  131:     [ 'A '9 1 + -  ] literal -
  132:     dup 9 u<= IF
  133:       drop false EXIT
  134:     THEN
  135:   THEN
  136:   dup base @ u>= IF
  137:     drop false EXIT
  138:   THEN
  139:   true ;
  140: 
  141: : accumulate ( +d0 addr digit - +d1 addr )
  142:   swap >r swap  base @  um* drop rot  base @  um* d+ r> ;
  143: 
  144: : >number ( d addr count -- d addr count ) \ core
  145:     0
  146:     ?DO
  147: 	count digit?
  148:     WHILE
  149: 	accumulate
  150:     LOOP
  151:         0
  152:     ELSE
  153: 	1- I' I -
  154: 	UNLOOP
  155:     THEN ;
  156: 
  157: \ s>d um/mod						21mar93py
  158: 
  159: : s>d ( n -- d ) \ core		s-to-d
  160:     dup 0< ;
  161: 
  162: : ud/mod ( ud1 u2 -- urem udquot ) \ gforth
  163:     >r 0 r@ um/mod r> swap >r
  164:     um/mod r> ;
  165: 
  166: \ catch throw                                          23feb93py
  167: \ bounce                                                08jun93jaw
  168: 
  169: \ !! allow the user to add rollback actions    anton
  170: \ !! use a separate exception stack?           anton
  171: 
  172: has? glocals [IF]
  173: : lp@ ( -- addr ) \ gforth	l-p-fetch
  174:  laddr# [ 0 , ] ;
  175: [THEN]
  176: 
  177: \- 'catch Defer 'catch
  178: \- 'throw Defer 'throw
  179: 
  180: ' noop IS 'catch
  181: ' noop IS 'throw
  182: 
  183: : catch ( x1 .. xn xt -- y1 .. ym 0 / z1 .. zn error ) \ exception
  184:     'catch
  185:     sp@ >r
  186: [ has? floating [IF] ]
  187:     fp@ >r
  188: [ [THEN] ]
  189: [ has? glocals [IF] ]
  190:     lp@ >r
  191: [ [THEN] ]
  192:     handler @ >r
  193:     rp@ handler !
  194:     execute
  195:     r> handler ! rdrop 
  196: [ has? floating [IF] ]
  197:     rdrop
  198: [ [THEN] ]
  199: [ has? glocals [IF] ]
  200:     rdrop
  201: [ [THEN] ]
  202:     0 ;
  203: 
  204: : throw ( y1 .. ym error/0 -- y1 .. ym / z1 .. zn error ) \ exception
  205:     ?DUP IF
  206: 	[ has? header [IF] here 9 cells ! [THEN] ] \ entry point for signal handler
  207: [ has? interpreter [IF] ]
  208: 	handler @ dup 0= IF
  209: [ has? os [IF] ]
  210: 	    2 (bye)
  211: [ [ELSE] ]
  212: 	    quit
  213: [ [THEN] ]
  214: 	THEN
  215: [ [THEN] ]
  216: 	rp!
  217: 	r> handler !
  218: [ has? glocals [IF] ]
  219:         r> lp!
  220: [ [THEN] ]
  221: [ has? floating [IF] ]
  222: 	r> fp!
  223: [ [THEN] ]
  224: 	r> swap >r sp! drop r>
  225: 	'throw
  226:     THEN ;
  227: 
  228: \ Bouncing is very fine,
  229: \ programming without wasting time...   jaw
  230: : bounce ( y1 .. ym error/0 -- y1 .. ym error / y1 .. ym ) \ gforth
  231: \ a throw without data or fp stack restauration
  232:   ?DUP IF
  233:       handler @ rp!
  234:       r> handler !
  235: [ has? glocals [IF] ]
  236:       r> lp!
  237: [ [THEN] ]
  238: [ has? floating [IF] ]
  239:       rdrop
  240: [ [THEN] ]
  241:       rdrop
  242:       'throw
  243:   THEN ;
  244: 
  245: \ (abort")
  246: 
  247: : (abort")
  248:     "lit >r
  249:     IF
  250: 	r> "error ! -2 throw
  251:     THEN
  252:     rdrop ;
  253: 
  254: : abort ( ?? -- ?? ) \ core,exception-ext
  255:     -1 throw ;
  256: 
  257: \ ?stack                                               23feb93py
  258: 
  259: : ?stack ( ?? -- ?? ) \ gforth
  260:     sp@ sp0 @ u> IF    -4 throw  THEN
  261: [ has? floating [IF] ]
  262:     fp@ fp0 @ u> IF  -&45 throw  THEN
  263: [ [THEN] ]
  264: ;
  265: \ ?stack should be code -- it touches an empty stack!
  266: 
  267: \ DEPTH                                                 9may93jaw
  268: 
  269: : depth ( -- +n ) \ core
  270:     sp@ sp0 @ swap - cell / ;
  271: : clearstack ( ... -- )
  272:     sp0 @ sp! ;
  273: 
  274: \ Strings						 22feb93py
  275: 
  276: : "lit ( -- addr )
  277:   r> r> dup count + aligned >r swap >r ;
  278: 
  279: \ */MOD */                                              17may93jaw
  280: 
  281: \ !! I think */mod should have the same rounding behaviour as / - anton
  282: : */mod ( n1 n2 n3 -- n4 n5 ) \ core	star-slash-mod
  283:     >r m* r> sm/rem ;
  284: 
  285: : */ ( n1 n2 n3 -- n4 ) \ core	star-slash
  286:     */mod nip ;
  287: 
  288: \ HEX DECIMAL                                           2may93jaw
  289: 
  290: : decimal ( -- ) \ core
  291:     a base ! ;
  292: : hex ( -- ) \ core-ext
  293:     10 base ! ;
  294: 

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