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