Annotation of gforth/kernel/basics.fs, revision 1.13
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
1.13 ! crook 65: \G Return the amount of free space remaining (in address units) in
! 66: \G the region addressed by @code{here}.
1.2 anton 67: dictionary-end here - [ word-pno-size pad-minsize + ] Literal - ;
68:
1.1 anton 69: \ here is used for pad calculation!
70:
71: : dp ( -- addr ) \ gforth
72: dpp @ ;
1.13 ! crook 73: : here ( -- addr ) \ core
! 74: \G Return the address of the next free location in data space.
1.1 anton 75: dp @ ;
76:
77: \ on off 23feb93py
78:
1.4 jwilke 79: \ on is used by docol:
1.1 anton 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:
1.13 ! crook 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.
1.1 anton 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:
1.5 jwilke 187: has? glocals [IF]
1.12 crook 188: : lp@ ( -- addr ) \ gforth lp-fetch
1.1 anton 189: laddr# [ 0 , ] ;
190: [THEN]
191:
192: \- 'catch Defer 'catch
193: \- 'throw Defer 'throw
194:
195: ' noop IS 'catch
196: ' noop IS 'throw
197:
1.8 anton 198: Defer store-backtrace
199: ' noop IS store-backtrace
200:
1.1 anton 201: : catch ( x1 .. xn xt -- y1 .. ym 0 / z1 .. zn error ) \ exception
202: 'catch
203: sp@ >r
1.5 jwilke 204: [ has? floating [IF] ]
1.1 anton 205: fp@ >r
206: [ [THEN] ]
1.5 jwilke 207: [ has? glocals [IF] ]
1.1 anton 208: lp@ >r
209: [ [THEN] ]
210: handler @ >r
211: rp@ handler !
1.8 anton 212: backtrace-empty on
1.1 anton 213: execute
1.3 jwilke 214: r> handler ! rdrop
1.5 jwilke 215: [ has? floating [IF] ]
1.3 jwilke 216: rdrop
217: [ [THEN] ]
1.5 jwilke 218: [ has? glocals [IF] ]
1.3 jwilke 219: rdrop
220: [ [THEN] ]
221: 0 ;
1.1 anton 222:
223: : throw ( y1 .. ym error/0 -- y1 .. ym / z1 .. zn error ) \ exception
224: ?DUP IF
1.6 pazsan 225: [ has? header [IF] here 9 cells ! [THEN] ] \ entry point for signal handler
1.8 anton 226: store-backtrace
1.5 jwilke 227: [ has? interpreter [IF] ]
1.1 anton 228: handler @ dup 0= IF
1.5 jwilke 229: [ has? os [IF] ]
1.1 anton 230: 2 (bye)
231: [ [ELSE] ]
232: quit
233: [ [THEN] ]
234: THEN
235: [ [THEN] ]
236: rp!
237: r> handler !
1.5 jwilke 238: [ has? glocals [IF] ]
1.1 anton 239: r> lp!
240: [ [THEN] ]
1.5 jwilke 241: [ has? floating [IF] ]
1.1 anton 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
1.8 anton 253: store-backtrace
1.1 anton 254: handler @ rp!
255: r> handler !
1.5 jwilke 256: [ has? glocals [IF] ]
1.1 anton 257: r> lp!
258: [ [THEN] ]
1.5 jwilke 259: [ has? floating [IF] ]
1.1 anton 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 ;
1.6 pazsan 274:
275: : abort ( ?? -- ?? ) \ core,exception-ext
1.12 crook 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}.
1.6 pazsan 279: -1 throw ;
1.1 anton 280:
281: \ ?stack 23feb93py
282:
283: : ?stack ( ?? -- ?? ) \ gforth
1.3 jwilke 284: sp@ sp0 @ u> IF -4 throw THEN
1.5 jwilke 285: [ has? floating [IF] ]
1.3 jwilke 286: fp@ fp0 @ u> IF -&45 throw THEN
1.1 anton 287: [ [THEN] ]
288: ;
289: \ ?stack should be code -- it touches an empty stack!
290:
291: \ DEPTH 9may93jaw
292:
1.9 crook 293: : depth ( -- +n ) \ core depth
1.12 crook 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.
1.3 jwilke 296: sp@ sp0 @ swap - cell / ;
1.9 crook 297:
298: : clearstack ( ... -- ) \ gforth clear-stack
299: \G remove and discard all/any items from the data stack.
1.3 jwilke 300: sp0 @ sp! ;
1.1 anton 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
1.9 crook 319: \G Set the numeric conversion radix (the value of @code{BASE}) to 10
320: \G (decimal).
1.1 anton 321: a base ! ;
322: : hex ( -- ) \ core-ext
1.9 crook 323: \G Set the numeric conversion radix (the value of @code{BASE}) to 16
324: \G (hexadecimal).
1.1 anton 325: 10 base ! ;
326:
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>