1: \ kernel.fs GForth kernel 17dec92py
2:
3: \ Copyright (C) 1995,1998,2000,2003,2004,2005 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., 59 Temple Place, Suite 330, Boston, MA 02111, USA.
20:
21: \ Idea and implementation: Bernd Paysan (py)
22:
23: \ Needs:
24:
25: require ./vars.fs
26: require ../compat/strcomp.fs
27:
28: hex
29:
30: \ labels for some code addresses
31:
32: \- NIL NIL AConstant NIL \ gforth
33:
34: \ Aliases
35:
36: [IFUNDEF] r@
37: ' i Alias r@ ( -- w ; R: w -- w ) \ core r-fetch
38: [THEN]
39:
40: \ !! this is machine-dependent, but works on all but the strangest machines
41:
42: : maxaligned ( addr1 -- addr2 ) \ gforth
43: \G @i{addr2} is the first address after @i{addr1} that satisfies
44: \G all alignment restrictions.
45: [ /maxalign 1 - ] Literal + [ 0 /maxalign - ] Literal and ;
46: \ !! machine-dependent and won't work if "0 >body" <> "0 >body
47: \G maxaligned"
48: ' maxaligned Alias cfaligned ( addr1 -- addr2 ) \ gforth
49: \G @i{addr2} is the first address after @i{addr1} that is aligned for
50: \G a code field (i.e., such that the corresponding body is maxaligned).
51:
52: : chars ( n1 -- n2 ) \ core
53: \G @i{n2} is the number of address units of @i{n1} chars.""
54: ; immediate
55:
56:
57: \ : A! ( addr1 addr2 -- ) \ gforth
58: \ dup relon ! ;
59: \ : A, ( addr -- ) \ gforth
60: \ here cell allot A! ;
61: ' ! alias A! ( addr1 addr2 -- ) \ gforth
62:
63: \ UNUSED 17may93jaw
64:
65: has? ec [IF]
66: unlock ram-dictionary borders nip lock
67: AConstant dictionary-end
68: [ELSE]
69: has? header [IF]
70: : dictionary-end ( -- addr )
71: forthstart [ 3 cells image-header + ] Aliteral @ + ;
72: [ELSE]
73: : forthstart 0 ;
74: : dictionary-end ( -- addr )
75: forthstart [ has? kernel-size ] Literal + ;
76: [THEN]
77: [THEN]
78:
79: : usable-dictionary-end ( -- addr )
80: dictionary-end [ word-pno-size pad-minsize + ] Literal - ;
81:
82: : unused ( -- u ) \ core-ext
83: \G Return the amount of free space remaining (in address units) in
84: \G the region addressed by @code{here}.
85: usable-dictionary-end here - ;
86:
87: has? ec [IF]
88: : in-dictionary? ( x -- f )
89: dictionary-end u< ;
90: [ELSE]
91: : in-dictionary? ( x -- f )
92: forthstart dictionary-end within ;
93: [THEN]
94:
95: \ here is used for pad calculation!
96:
97: : dp ( -- addr ) \ gforth
98: dpp @ ;
99: : here ( -- addr ) \ core
100: \G Return the address of the next free location in data space.
101: dp @ ;
102:
103: \ on off 23feb93py
104:
105: \ on is used by docol:
106: : on ( a-addr -- ) \ gforth
107: \G Set the (value of the) variable at @i{a-addr} to @code{true}.
108: true swap ! ;
109: : off ( a-addr -- ) \ gforth
110: \G Set the (value of the) variable at @i{a-addr} to @code{false}.
111: false swap ! ;
112:
113: \ dabs roll 17may93jaw
114:
115: : dabs ( d -- ud ) \ double d-abs
116: dup 0< IF dnegate THEN ;
117:
118: : roll ( x0 x1 .. xn n -- x1 .. xn x0 ) \ core-ext
119: \ dup 1+ pick >r
120: \ cells sp@ cell+ dup cell+ rot move drop r> ;
121: dup 0<= if
122: drop
123: else
124: swap >r 1- recurse r> swap
125: then ;
126:
127: \ place bounds 13feb93py
128:
129: : place ( addr len to -- ) \ gforth
130: over >r rot over 1+ r> move c! ;
131: : bounds ( addr u -- addr+u addr ) \ gforth
132: \G Given a memory block represented by starting address @i{addr}
133: \G and length @i{u} in aus, produce the end address @i{addr+u} and
134: \G the start address in the right order for @code{u+do} or
135: \G @code{?do}.
136: over + swap ;
137:
138: \ (word) 22feb93py
139:
140: : scan ( addr1 n1 char -- addr2 n2 ) \ gforth
141: \G skip all characters not equal to char
142: >r
143: BEGIN
144: dup
145: WHILE
146: over c@ r@ <>
147: WHILE
148: 1 /string
149: REPEAT THEN
150: rdrop ;
151: : skip ( addr1 n1 char -- addr2 n2 ) \ gforth
152: \G skip all characters equal to char
153: >r
154: BEGIN
155: dup
156: WHILE
157: over c@ r@ =
158: WHILE
159: 1 /string
160: REPEAT THEN
161: rdrop ;
162:
163: \ digit? 17dec92py
164:
165: : digit? ( char -- digit true/ false ) \ gforth
166: toupper [char] 0 - dup 9 u> IF
167: [ char A char 9 1 + - ] literal -
168: dup 9 u<= IF
169: drop false EXIT
170: THEN
171: THEN
172: dup base @ u>= IF
173: drop false EXIT
174: THEN
175: true ;
176:
177: : accumulate ( +d0 addr digit - +d1 addr )
178: swap >r swap base @ um* drop rot base @ um* d+ r> ;
179:
180: : >number ( ud1 c-addr1 u1 -- ud2 c-addr2 u2 ) \ core to-number
181: \G Attempt to convert the character string @var{c-addr1 u1} to an
182: \G unsigned number in the current number base. The double
183: \G @var{ud1} accumulates the result of the conversion to form
184: \G @var{ud2}. Conversion continues, left-to-right, until the whole
185: \G string is converted or a character that is not convertable in
186: \G the current number base is encountered (including + or -). For
187: \G each convertable character, @var{ud1} is first multiplied by
188: \G the value in @code{BASE} and then incremented by the value
189: \G represented by the character. @var{c-addr2} is the location of
190: \G the first unconverted character (past the end of the string if
191: \G the whole string was converted). @var{u2} is the number of
192: \G unconverted characters in the string. Overflow is not detected.
193: 0
194: ?DO
195: count digit?
196: WHILE
197: accumulate
198: LOOP
199: 0
200: ELSE
201: 1- I' I -
202: UNLOOP
203: THEN ;
204:
205: \ s>d um/mod 21mar93py
206:
207: : s>d ( n -- d ) \ core s-to-d
208: dup 0< ;
209:
210: : ud/mod ( ud1 u2 -- urem udquot ) \ gforth
211: >r 0 r@ um/mod r> swap >r
212: um/mod r> ;
213:
214: \ catch throw 23feb93py
215:
216: has? glocals [IF]
217: : lp@ ( -- addr ) \ gforth lp-fetch
218: laddr# [ 0 , ] ;
219: [THEN]
220:
221: has? ec [IF]
222: : catch ( ... xt -- ... 0 )
223: handler @ >r sp@ >r
224: rp@ handler ! execute 0 r> drop r> handler ! ;
225: : throw ( error -- error ) dup 0= IF drop EXIT THEN
226: handler @ rp! r> swap >r sp! r> r> handler ! ;
227: [ELSE]
228: defer catch ( x1 .. xn xt -- y1 .. ym 0 / z1 .. zn error ) \ exception
229: \G @code{Executes} @i{xt}. If execution returns normally,
230: \G @code{catch} pushes 0 on the stack. If execution returns through
231: \G @code{throw}, all the stacks are reset to the depth on entry to
232: \G @code{catch}, and the TOS (the @i{xt} position) is replaced with
233: \G the throw code.
234:
235: :noname ( ... xt -- ... 0 )
236: execute 0 ;
237: is catch
238:
239: defer throw ( y1 .. ym nerror -- y1 .. ym / z1 .. zn error ) \ exception
240: \G If @i{nerror} is 0, drop it and continue. Otherwise, transfer
241: \G control to the next dynamically enclosing exception handler, reset
242: \G the stacks accordingly, and push @i{nerror}.
243: defer rethrow ( y1 .. ym nerror -- y1 .. ym / z1 .. zn error ) \ exception
244: \G If @i{nerror} is 0, drop it and continue. Otherwise, transfer
245: \G control to the next dynamically enclosing exception handler, reset
246: \G the stacks accordingly, and push @i{nerror}. Doesn't reset the error stack
247:
248: :noname ( y1 .. ym error -- y1 .. ym / z1 .. zn error )
249: ?dup if
250: [ has? header [IF] here image-header 9 cells + ! [THEN] ]
251: cr .error cr
252: [ has? file [IF] ] script? IF 1 (bye) ELSE quit THEN
253: [ [ELSE] ] quit [ [THEN] ]
254: then ;
255: dup is throw
256: is rethrow
257: [THEN]
258:
259: \ (abort")
260:
261: : c(abort") ( c-addr -- )
262: "error ! -2 throw ;
263:
264: : (abort")
265: "lit >r
266: IF
267: r> "error ! -2 throw
268: THEN
269: rdrop ;
270:
271: : abort ( ?? -- ?? ) \ core,exception-ext
272: \G @code{-1 throw}.
273: -1 throw ;
274:
275: \ ?stack 23feb93py
276:
277: : ?stack ( ?? -- ?? ) \ gforth
278: sp@ sp0 @ u> IF -4 throw THEN
279: [ has? floating [IF] ]
280: fp@ fp0 @ u> IF -&45 throw THEN
281: [ [THEN] ]
282: ;
283: \ ?stack should be code -- it touches an empty stack!
284:
285: \ DEPTH 9may93jaw
286:
287: : depth ( -- +n ) \ core depth
288: \G @var{+n} is the number of values that were on the data stack before
289: \G @var{+n} itself was placed on the stack.
290: sp@ sp0 @ swap - cell / ;
291:
292: : clearstack ( ... -- ) \ gforth clear-stack
293: \G remove and discard all/any items from the data stack.
294: sp0 @ sp! ;
295:
296: : clearstacks ( ... -- ) \ gforth clear-stacks
297: \G empty data and FP stack
298: clearstack
299: [ has? floating [IF] ]
300: fp0 @ fp!
301: [ [THEN] ]
302: ;
303:
304: \ Strings 22feb93py
305:
306: : "lit ( -- addr )
307: r> r> dup count + aligned >r swap >r ;
308:
309: \ HEX DECIMAL 2may93jaw
310:
311: : decimal ( -- ) \ core
312: \G Set @code{base} to &10 (decimal).
313: a base ! ;
314: : hex ( -- ) \ core-ext
315: \G Set @code{base} to &16 (hexadecimal).
316: 10 base ! ;
317:
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