Annotation of gforth/kernel/basics.fs, revision 1.12
1.1 anton 1: \ kernel.fs GForth kernel 17dec92py
2:
1.7 anton 3: \ Copyright (C) 1995,1998 Free Software Foundation, Inc.
1.1 anton 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:
1.4 jwilke 31: [IFUNDEF] r@
1.1 anton 32: ' i Alias r@ ( -- w ; R: w -- w ) \ core r-fetch
1.12 ! crook 33: \G Copy @var{w} from the return stack to the data stack.
1.4 jwilke 34: [THEN]
1.1 anton 35:
36: \ !! this is machine-dependent, but works on all but the strangest machines
37:
1.10 anton 38: : maxaligned ( addr -- f-addr ) \ gforth
1.1 anton 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:
1.2 anton 53: \ UNUSED 17may93jaw
54:
1.4 jwilke 55: has? ec
56: [IF]
57: unlock ram-dictionary area nip lock
58: Constant dictionary-end
59: [ELSE]
1.2 anton 60: : dictionary-end ( -- addr )
61: forthstart [ 3 cells ] Aliteral @ + ;
1.4 jwilke 62: [THEN]
1.2 anton 63:
64: : unused ( -- u ) \ core-ext
65: dictionary-end here - [ word-pno-size pad-minsize + ] Literal - ;
66:
1.1 anton 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:
1.4 jwilke 76: \ on is used by docol:
1.1 anton 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:
1.11 anton 144: : >number ( d1 addr1 count1 -- d2 addr2 count2 ) \ core
1.1 anton 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:
1.5 jwilke 172: has? glocals [IF]
1.12 ! crook 173: : lp@ ( -- addr ) \ gforth lp-fetch
1.1 anton 174: laddr# [ 0 , ] ;
175: [THEN]
176:
177: \- 'catch Defer 'catch
178: \- 'throw Defer 'throw
179:
180: ' noop IS 'catch
181: ' noop IS 'throw
182:
1.8 anton 183: Defer store-backtrace
184: ' noop IS store-backtrace
185:
1.1 anton 186: : catch ( x1 .. xn xt -- y1 .. ym 0 / z1 .. zn error ) \ exception
187: 'catch
188: sp@ >r
1.5 jwilke 189: [ has? floating [IF] ]
1.1 anton 190: fp@ >r
191: [ [THEN] ]
1.5 jwilke 192: [ has? glocals [IF] ]
1.1 anton 193: lp@ >r
194: [ [THEN] ]
195: handler @ >r
196: rp@ handler !
1.8 anton 197: backtrace-empty on
1.1 anton 198: execute
1.3 jwilke 199: r> handler ! rdrop
1.5 jwilke 200: [ has? floating [IF] ]
1.3 jwilke 201: rdrop
202: [ [THEN] ]
1.5 jwilke 203: [ has? glocals [IF] ]
1.3 jwilke 204: rdrop
205: [ [THEN] ]
206: 0 ;
1.1 anton 207:
208: : throw ( y1 .. ym error/0 -- y1 .. ym / z1 .. zn error ) \ exception
209: ?DUP IF
1.6 pazsan 210: [ has? header [IF] here 9 cells ! [THEN] ] \ entry point for signal handler
1.8 anton 211: store-backtrace
1.5 jwilke 212: [ has? interpreter [IF] ]
1.1 anton 213: handler @ dup 0= IF
1.5 jwilke 214: [ has? os [IF] ]
1.1 anton 215: 2 (bye)
216: [ [ELSE] ]
217: quit
218: [ [THEN] ]
219: THEN
220: [ [THEN] ]
221: rp!
222: r> handler !
1.5 jwilke 223: [ has? glocals [IF] ]
1.1 anton 224: r> lp!
225: [ [THEN] ]
1.5 jwilke 226: [ has? floating [IF] ]
1.1 anton 227: r> fp!
228: [ [THEN] ]
229: r> swap >r sp! drop r>
230: 'throw
231: THEN ;
232:
233: \ Bouncing is very fine,
234: \ programming without wasting time... jaw
235: : bounce ( y1 .. ym error/0 -- y1 .. ym error / y1 .. ym ) \ gforth
236: \ a throw without data or fp stack restauration
237: ?DUP IF
1.8 anton 238: store-backtrace
1.1 anton 239: handler @ rp!
240: r> handler !
1.5 jwilke 241: [ has? glocals [IF] ]
1.1 anton 242: r> lp!
243: [ [THEN] ]
1.5 jwilke 244: [ has? floating [IF] ]
1.1 anton 245: rdrop
246: [ [THEN] ]
247: rdrop
248: 'throw
249: THEN ;
250:
251: \ (abort")
252:
253: : (abort")
254: "lit >r
255: IF
256: r> "error ! -2 throw
257: THEN
258: rdrop ;
1.6 pazsan 259:
260: : abort ( ?? -- ?? ) \ core,exception-ext
1.12 ! crook 261: \G Empty the data stack and perform the functions of @code{quit}.
! 262: \G Since the exception word set is present, this is performed by
! 263: \G @code{-1 throw}.
1.6 pazsan 264: -1 throw ;
1.1 anton 265:
266: \ ?stack 23feb93py
267:
268: : ?stack ( ?? -- ?? ) \ gforth
1.3 jwilke 269: sp@ sp0 @ u> IF -4 throw THEN
1.5 jwilke 270: [ has? floating [IF] ]
1.3 jwilke 271: fp@ fp0 @ u> IF -&45 throw THEN
1.1 anton 272: [ [THEN] ]
273: ;
274: \ ?stack should be code -- it touches an empty stack!
275:
276: \ DEPTH 9may93jaw
277:
1.9 crook 278: : depth ( -- +n ) \ core depth
1.12 ! crook 279: \G @var{+n} is the number of values that were on the data stack before
! 280: \G @var{+n} itself was placed on the stack.
1.3 jwilke 281: sp@ sp0 @ swap - cell / ;
1.9 crook 282:
283: : clearstack ( ... -- ) \ gforth clear-stack
284: \G remove and discard all/any items from the data stack.
1.3 jwilke 285: sp0 @ sp! ;
1.1 anton 286:
287: \ Strings 22feb93py
288:
289: : "lit ( -- addr )
290: r> r> dup count + aligned >r swap >r ;
291:
292: \ */MOD */ 17may93jaw
293:
294: \ !! I think */mod should have the same rounding behaviour as / - anton
295: : */mod ( n1 n2 n3 -- n4 n5 ) \ core star-slash-mod
296: >r m* r> sm/rem ;
297:
298: : */ ( n1 n2 n3 -- n4 ) \ core star-slash
299: */mod nip ;
300:
301: \ HEX DECIMAL 2may93jaw
302:
303: : decimal ( -- ) \ core
1.9 crook 304: \G Set the numeric conversion radix (the value of @code{BASE}) to 10
305: \G (decimal).
1.1 anton 306: a base ! ;
307: : hex ( -- ) \ core-ext
1.9 crook 308: \G Set the numeric conversion radix (the value of @code{BASE}) to 16
309: \G (hexadecimal).
1.1 anton 310: 10 base ! ;
311:
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>