Annotation of gforth/kernel/basics.fs, revision 1.16
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.12 crook 37: \G Copy @var{w} from the return stack to the data stack.
1.4 jwilke 38: [THEN]
1.1 anton 39:
40: \ !! this is machine-dependent, but works on all but the strangest machines
41:
1.10 anton 42: : maxaligned ( addr -- f-addr ) \ gforth
1.1 anton 43: [ /maxalign 1 - ] Literal + [ 0 /maxalign - ] Literal and ;
44: \ !! machine-dependent and won't work if "0 >body" <> "0 >body maxaligned"
45: ' maxaligned Alias cfaligned ( addr1 -- addr2 ) \ gforth
46:
47: : chars ( n1 -- n2 ) \ core
1.15 crook 48: \G @i{n2} is the number of address units corresponding to @i{n1} chars.""
1.1 anton 49: ; immediate
50:
51:
52: \ : A! ( addr1 addr2 -- ) \ gforth
53: \ dup relon ! ;
54: \ : A, ( addr -- ) \ gforth
55: \ here cell allot A! ;
56: ' ! alias A! ( addr1 addr2 -- ) \ gforth
57:
1.2 anton 58: \ UNUSED 17may93jaw
59:
1.4 jwilke 60: has? ec
61: [IF]
62: unlock ram-dictionary area nip lock
63: Constant dictionary-end
64: [ELSE]
1.2 anton 65: : dictionary-end ( -- addr )
66: forthstart [ 3 cells ] Aliteral @ + ;
1.4 jwilke 67: [THEN]
1.2 anton 68:
1.14 anton 69: : usable-dictionary-end ( -- addr )
70: dictionary-end [ word-pno-size pad-minsize + ] Literal - ;
71:
1.2 anton 72: : unused ( -- u ) \ core-ext
1.13 crook 73: \G Return the amount of free space remaining (in address units) in
74: \G the region addressed by @code{here}.
1.14 anton 75: usable-dictionary-end here - ;
1.2 anton 76:
1.1 anton 77: \ here is used for pad calculation!
78:
79: : dp ( -- addr ) \ gforth
80: dpp @ ;
1.13 crook 81: : here ( -- addr ) \ core
82: \G Return the address of the next free location in data space.
1.1 anton 83: dp @ ;
84:
85: \ on off 23feb93py
86:
1.4 jwilke 87: \ on is used by docol:
1.15 crook 88: : on ( a-addr -- ) \ gforth
89: \G Set the (value of the) variable at @i{a-addr} to @code{true}.
1.1 anton 90: true swap ! ;
1.15 crook 91: : off ( a-addr -- ) \ gforth
92: \G Set the (value of the) variable at @i{a-addr} to @code{false}.
1.1 anton 93: false swap ! ;
94:
95: \ dabs roll 17may93jaw
96:
97: : dabs ( d1 -- d2 ) \ double
98: dup 0< IF dnegate THEN ;
99:
100: : roll ( x0 x1 .. xn n -- x1 .. xn x0 ) \ core-ext
101: dup 1+ pick >r
102: cells sp@ cell+ dup cell+ rot move drop r> ;
103:
104: \ place bounds 13feb93py
105:
106: : place ( addr len to -- ) \ gforth
107: over >r rot over 1+ r> move c! ;
108: : bounds ( beg count -- end beg ) \ gforth
109: over + swap ;
110:
111: \ (word) 22feb93py
112:
113: : scan ( addr1 n1 char -- addr2 n2 ) \ gforth
114: \ skip all characters not equal to char
115: >r
116: BEGIN
117: dup
118: WHILE
119: over c@ r@ <>
120: WHILE
121: 1 /string
122: REPEAT THEN
123: rdrop ;
124: : skip ( addr1 n1 char -- addr2 n2 ) \ gforth
125: \ skip all characters equal to char
126: >r
127: BEGIN
128: dup
129: WHILE
130: over c@ r@ =
131: WHILE
132: 1 /string
133: REPEAT THEN
134: rdrop ;
135:
136: \ digit? 17dec92py
137:
138: : digit? ( char -- digit true/ false ) \ gforth
139: base @ $100 =
140: IF
141: true EXIT
142: THEN
143: toupper [char] 0 - dup 9 u> IF
1.16 ! jwilke 144: [ char A char 9 1 + - ] literal -
1.1 anton 145: dup 9 u<= IF
146: drop false EXIT
147: THEN
148: THEN
149: dup base @ u>= IF
150: drop false EXIT
151: THEN
152: true ;
153:
154: : accumulate ( +d0 addr digit - +d1 addr )
155: swap >r swap base @ um* drop rot base @ um* d+ r> ;
156:
1.13 crook 157: : >number ( ud1 c-addr1 u1 -- ud2 c-addr2 u2 ) \ core
158: \G Attempt to convert the character string @var{c-addr1, u1} to an
159: \G unsigned number in the current number base. The double
160: \G @var{ud1} accumulates the result of the conversion to form
161: \G @var{ud2}. Conversion continues, left-to-right, until the whole
162: \G string is converted or a character that is not convertable in
163: \G the current number base is encountered (including + or -). For
164: \G each convertable character, @var{ud1} is first multiplied by
165: \G the value in @code{BASE} and then incremented by the value
166: \G represented by the character. @var{c-addr2} is the location of
167: \G the first unconverted character (past the end of the string if
168: \G the whole string was converted). @var{u2} is the number of
169: \G unconverted characters in the string. Overflow is not detected.
1.1 anton 170: 0
171: ?DO
172: count digit?
173: WHILE
174: accumulate
175: LOOP
176: 0
177: ELSE
178: 1- I' I -
179: UNLOOP
180: THEN ;
181:
182: \ s>d um/mod 21mar93py
183:
184: : s>d ( n -- d ) \ core s-to-d
185: dup 0< ;
186:
187: : ud/mod ( ud1 u2 -- urem udquot ) \ gforth
188: >r 0 r@ um/mod r> swap >r
189: um/mod r> ;
190:
191: \ catch throw 23feb93py
192: \ bounce 08jun93jaw
193:
194: \ !! allow the user to add rollback actions anton
195: \ !! use a separate exception stack? anton
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:
202: \- 'catch Defer 'catch
203: \- 'throw Defer 'throw
204:
205: ' noop IS 'catch
206: ' noop IS 'throw
207:
1.16 ! jwilke 208: has? backtrace [IF]
1.8 anton 209: Defer store-backtrace
210: ' noop IS store-backtrace
1.16 ! jwilke 211: [THEN]
1.8 anton 212:
1.1 anton 213: : catch ( x1 .. xn xt -- y1 .. ym 0 / z1 .. zn error ) \ exception
214: 'catch
215: sp@ >r
1.5 jwilke 216: [ has? floating [IF] ]
1.1 anton 217: fp@ >r
218: [ [THEN] ]
1.5 jwilke 219: [ has? glocals [IF] ]
1.1 anton 220: lp@ >r
221: [ [THEN] ]
222: handler @ >r
223: rp@ handler !
1.16 ! jwilke 224: [ has? backtrace [IF] ]
1.8 anton 225: backtrace-empty on
1.16 ! jwilke 226: [ [THEN] ]
1.1 anton 227: execute
1.3 jwilke 228: r> handler ! rdrop
1.5 jwilke 229: [ has? floating [IF] ]
1.3 jwilke 230: rdrop
231: [ [THEN] ]
1.5 jwilke 232: [ has? glocals [IF] ]
1.3 jwilke 233: rdrop
234: [ [THEN] ]
235: 0 ;
1.1 anton 236:
237: : throw ( y1 .. ym error/0 -- y1 .. ym / z1 .. zn error ) \ exception
238: ?DUP IF
1.6 pazsan 239: [ has? header [IF] here 9 cells ! [THEN] ] \ entry point for signal handler
1.16 ! jwilke 240: [ has? backtrace [IF] ]
1.8 anton 241: store-backtrace
1.16 ! jwilke 242: [ [THEN] ]
1.5 jwilke 243: [ has? interpreter [IF] ]
1.1 anton 244: handler @ dup 0= IF
1.5 jwilke 245: [ has? os [IF] ]
1.1 anton 246: 2 (bye)
247: [ [ELSE] ]
248: quit
249: [ [THEN] ]
250: THEN
251: [ [THEN] ]
252: rp!
253: r> handler !
1.5 jwilke 254: [ has? glocals [IF] ]
1.1 anton 255: r> lp!
256: [ [THEN] ]
1.5 jwilke 257: [ has? floating [IF] ]
1.1 anton 258: r> fp!
259: [ [THEN] ]
260: r> swap >r sp! drop r>
261: 'throw
262: THEN ;
263:
264: \ Bouncing is very fine,
265: \ programming without wasting time... jaw
266: : bounce ( y1 .. ym error/0 -- y1 .. ym error / y1 .. ym ) \ gforth
267: \ a throw without data or fp stack restauration
268: ?DUP IF
1.16 ! jwilke 269: [ has? backtrace [IF] ]
1.8 anton 270: store-backtrace
1.16 ! jwilke 271: [ [THEN] ]
1.1 anton 272: handler @ rp!
273: r> handler !
1.5 jwilke 274: [ has? glocals [IF] ]
1.1 anton 275: r> lp!
276: [ [THEN] ]
1.5 jwilke 277: [ has? floating [IF] ]
1.1 anton 278: rdrop
279: [ [THEN] ]
280: rdrop
281: 'throw
282: THEN ;
283:
284: \ (abort")
285:
286: : (abort")
287: "lit >r
288: IF
289: r> "error ! -2 throw
290: THEN
291: rdrop ;
1.6 pazsan 292:
293: : abort ( ?? -- ?? ) \ core,exception-ext
1.12 crook 294: \G Empty the data stack and perform the functions of @code{quit}.
295: \G Since the exception word set is present, this is performed by
296: \G @code{-1 throw}.
1.6 pazsan 297: -1 throw ;
1.1 anton 298:
299: \ ?stack 23feb93py
300:
301: : ?stack ( ?? -- ?? ) \ gforth
1.3 jwilke 302: sp@ sp0 @ u> IF -4 throw THEN
1.5 jwilke 303: [ has? floating [IF] ]
1.3 jwilke 304: fp@ fp0 @ u> IF -&45 throw THEN
1.1 anton 305: [ [THEN] ]
306: ;
307: \ ?stack should be code -- it touches an empty stack!
308:
309: \ DEPTH 9may93jaw
310:
1.9 crook 311: : depth ( -- +n ) \ core depth
1.12 crook 312: \G @var{+n} is the number of values that were on the data stack before
313: \G @var{+n} itself was placed on the stack.
1.3 jwilke 314: sp@ sp0 @ swap - cell / ;
1.9 crook 315:
316: : clearstack ( ... -- ) \ gforth clear-stack
317: \G remove and discard all/any items from the data stack.
1.3 jwilke 318: sp0 @ sp! ;
1.1 anton 319:
320: \ Strings 22feb93py
321:
322: : "lit ( -- addr )
323: r> r> dup count + aligned >r swap >r ;
324:
325: \ */MOD */ 17may93jaw
326:
327: \ !! I think */mod should have the same rounding behaviour as / - anton
328: : */mod ( n1 n2 n3 -- n4 n5 ) \ core star-slash-mod
329: >r m* r> sm/rem ;
330:
331: : */ ( n1 n2 n3 -- n4 ) \ core star-slash
332: */mod nip ;
333:
334: \ HEX DECIMAL 2may93jaw
335:
336: : decimal ( -- ) \ core
1.9 crook 337: \G Set the numeric conversion radix (the value of @code{BASE}) to 10
338: \G (decimal).
1.1 anton 339: a base ! ;
340: : hex ( -- ) \ core-ext
1.9 crook 341: \G Set the numeric conversion radix (the value of @code{BASE}) to 16
342: \G (hexadecimal).
1.1 anton 343: 10 base ! ;
344:
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