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