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