Annotation of gforth/kernel/basics.fs, revision 1.4
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:
1.4 ! jwilke 31: [IFUNDEF] r@
1.1 anton 32: ' i Alias r@ ( -- w ; R: w -- w ) \ core r-fetch
33: \G copy 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:
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:
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:
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-locals [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-floats [IF] ]
187: fp@ >r
188: [ [THEN] ]
189: [ has-locals [IF] ]
190: lp@ >r
191: [ [THEN] ]
192: handler @ >r
193: rp@ handler !
194: execute
1.3 jwilke 195: r> handler ! rdrop
196: [ has-floats [IF] ]
197: rdrop
198: [ [THEN] ]
199: [ has-locals [IF] ]
200: rdrop
201: [ [THEN] ]
202: 0 ;
1.1 anton 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-locals [IF] ]
219: r> lp!
220: [ [THEN] ]
221: [ has-floats [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-locals [IF] ]
236: r> lp!
237: [ [THEN] ]
238: [ has-floats [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: \ ?stack 23feb93py
255:
256: : ?stack ( ?? -- ?? ) \ gforth
1.3 jwilke 257: sp@ sp0 @ u> IF -4 throw THEN
1.1 anton 258: [ has-floats [IF] ]
1.3 jwilke 259: fp@ fp0 @ u> IF -&45 throw THEN
1.1 anton 260: [ [THEN] ]
261: ;
262: \ ?stack should be code -- it touches an empty stack!
263:
264: \ DEPTH 9may93jaw
265:
266: : depth ( -- +n ) \ core
1.3 jwilke 267: sp@ sp0 @ swap - cell / ;
1.1 anton 268: : clearstack ( ... -- )
1.3 jwilke 269: sp0 @ sp! ;
1.1 anton 270:
271: \ Strings 22feb93py
272:
273: : "lit ( -- addr )
274: r> r> dup count + aligned >r swap >r ;
275:
276: \ */MOD */ 17may93jaw
277:
278: \ !! I think */mod should have the same rounding behaviour as / - anton
279: : */mod ( n1 n2 n3 -- n4 n5 ) \ core star-slash-mod
280: >r m* r> sm/rem ;
281:
282: : */ ( n1 n2 n3 -- n4 ) \ core star-slash
283: */mod nip ;
284:
285: \ HEX DECIMAL 2may93jaw
286:
287: : decimal ( -- ) \ core
288: a base ! ;
289: : hex ( -- ) \ core-ext
290: 10 base ! ;
291:
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to basics.fs CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [gforth] / gforth / kernel