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