![[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|
Return to basics.fs CVS log | Up to [gforth] / gforth / kernel |
1.1 anton 1: \ kernel.fs GForth kernel 17dec92py
2:
3: \ Copyright (C) 1995 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., 675 Mass Ave, Cambridge, MA 02139, USA.
20:
21: \ Idea and implementation: Bernd Paysan (py)
22:
23: HEX
24:
25: \ labels for some code addresses
26:
27: \- NIL NIL AConstant NIL \ gforth
28:
29: \ Aliases
30:
31: ' i Alias r@ ( -- w ; R: w -- w ) \ core r-fetch
32: \G copy w from the return stack to the data stack
33:
34: \ !! this is machine-dependent, but works on all but the strangest machines
35:
36: : maxaligned ( addr -- f-addr ) \ float
37: [ /maxalign 1 - ] Literal + [ 0 /maxalign - ] Literal and ;
38: \ !! machine-dependent and won't work if "0 >body" <> "0 >body maxaligned"
39: ' maxaligned Alias cfaligned ( addr1 -- addr2 ) \ gforth
40:
41: : chars ( n1 -- n2 ) \ core
42: ; immediate
43:
44:
45: \ : A! ( addr1 addr2 -- ) \ gforth
46: \ dup relon ! ;
47: \ : A, ( addr -- ) \ gforth
48: \ here cell allot A! ;
49: ' ! alias A! ( addr1 addr2 -- ) \ gforth
50:
1.2 ! anton 51: \ UNUSED 17may93jaw
! 52:
! 53: : dictionary-end ( -- addr )
! 54: forthstart [ 3 cells ] Aliteral @ + ;
! 55:
! 56: : unused ( -- u ) \ core-ext
! 57: dictionary-end here - [ word-pno-size pad-minsize + ] Literal - ;
! 58:
1.1 anton 59: \ here is used for pad calculation!
60:
61: : dp ( -- addr ) \ gforth
62: dpp @ ;
63: : here ( -- here ) \ core
64: dp @ ;
65:
66: \ on off 23feb93py
67:
68: : on ( addr -- ) \ gforth
69: true swap ! ;
70: : off ( addr -- ) \ gforth
71: false swap ! ;
72:
73: \ dabs roll 17may93jaw
74:
75: : dabs ( d1 -- d2 ) \ double
76: dup 0< IF dnegate THEN ;
77:
78: : roll ( x0 x1 .. xn n -- x1 .. xn x0 ) \ core-ext
79: dup 1+ pick >r
80: cells sp@ cell+ dup cell+ rot move drop r> ;
81:
82: \ place bounds 13feb93py
83:
84: : place ( addr len to -- ) \ gforth
85: over >r rot over 1+ r> move c! ;
86: : bounds ( beg count -- end beg ) \ gforth
87: over + swap ;
88:
89: \ (word) 22feb93py
90:
91: : scan ( addr1 n1 char -- addr2 n2 ) \ gforth
92: \ skip all characters not equal to char
93: >r
94: BEGIN
95: dup
96: WHILE
97: over c@ r@ <>
98: WHILE
99: 1 /string
100: REPEAT THEN
101: rdrop ;
102: : skip ( addr1 n1 char -- addr2 n2 ) \ gforth
103: \ skip all characters equal to char
104: >r
105: BEGIN
106: dup
107: WHILE
108: over c@ r@ =
109: WHILE
110: 1 /string
111: REPEAT THEN
112: rdrop ;
113:
114: \ digit? 17dec92py
115:
116: : digit? ( char -- digit true/ false ) \ gforth
117: base @ $100 =
118: IF
119: true EXIT
120: THEN
121: toupper [char] 0 - dup 9 u> IF
122: [ 'A '9 1 + - ] literal -
123: dup 9 u<= IF
124: drop false EXIT
125: THEN
126: THEN
127: dup base @ u>= IF
128: drop false EXIT
129: THEN
130: true ;
131:
132: : accumulate ( +d0 addr digit - +d1 addr )
133: swap >r swap base @ um* drop rot base @ um* d+ r> ;
134:
135: : >number ( d addr count -- d addr count ) \ core
136: 0
137: ?DO
138: count digit?
139: WHILE
140: accumulate
141: LOOP
142: 0
143: ELSE
144: 1- I' I -
145: UNLOOP
146: THEN ;
147:
148: \ s>d um/mod 21mar93py
149:
150: : s>d ( n -- d ) \ core s-to-d
151: dup 0< ;
152:
153: : ud/mod ( ud1 u2 -- urem udquot ) \ gforth
154: >r 0 r@ um/mod r> swap >r
155: um/mod r> ;
156:
157: \ catch throw 23feb93py
158: \ bounce 08jun93jaw
159:
160: \ !! allow the user to add rollback actions anton
161: \ !! use a separate exception stack? anton
162:
163: has-locals [IF]
164: : lp@ ( -- addr ) \ gforth l-p-fetch
165: laddr# [ 0 , ] ;
166: [THEN]
167:
168: \- 'catch Defer 'catch
169: \- 'throw Defer 'throw
170:
171: ' noop IS 'catch
172: ' noop IS 'throw
173:
174: : catch ( x1 .. xn xt -- y1 .. ym 0 / z1 .. zn error ) \ exception
175: 'catch
176: sp@ >r
177: [ has-floats [IF] ]
178: fp@ >r
179: [ [THEN] ]
180: [ has-locals [IF] ]
181: lp@ >r
182: [ [THEN] ]
183: handler @ >r
184: rp@ handler !
185: execute
186: r> handler ! rdrop rdrop rdrop 0 ;
187:
188: : throw ( y1 .. ym error/0 -- y1 .. ym / z1 .. zn error ) \ exception
189: ?DUP IF
190: [ has-header [IF] here 9 cells ! [THEN] ] ] \ entry point for signal handler
191: [ has-interpreter [IF] ]
192: handler @ dup 0= IF
193: [ has-os [IF] ]
194: 2 (bye)
195: [ [ELSE] ]
196: quit
197: [ [THEN] ]
198: THEN
199: [ [THEN] ]
200: rp!
201: r> handler !
202: [ has-locals [IF] ]
203: r> lp!
204: [ [THEN] ]
205: [ has-floats [IF] ]
206: r> fp!
207: [ [THEN] ]
208: r> swap >r sp! drop r>
209: 'throw
210: THEN ;
211:
212: \ Bouncing is very fine,
213: \ programming without wasting time... jaw
214: : bounce ( y1 .. ym error/0 -- y1 .. ym error / y1 .. ym ) \ gforth
215: \ a throw without data or fp stack restauration
216: ?DUP IF
217: handler @ rp!
218: r> handler !
219: [ has-locals [IF] ]
220: r> lp!
221: [ [THEN] ]
222: [ has-floats [IF] ]
223: rdrop
224: [ [THEN] ]
225: rdrop
226: 'throw
227: THEN ;
228:
229: \ (abort")
230:
231: : (abort")
232: "lit >r
233: IF
234: r> "error ! -2 throw
235: THEN
236: rdrop ;
237:
238: \ ?stack 23feb93py
239:
240: : ?stack ( ?? -- ?? ) \ gforth
241: sp@ s0 @ u> IF -4 throw THEN
242: [ has-floats [IF] ]
243: fp@ f0 @ u> IF -&45 throw THEN
244: [ [THEN] ]
245: ;
246: \ ?stack should be code -- it touches an empty stack!
247:
248: \ DEPTH 9may93jaw
249:
250: : depth ( -- +n ) \ core
251: sp@ s0 @ swap - cell / ;
252: : clearstack ( ... -- )
253: s0 @ sp! ;
254:
255: \ Strings 22feb93py
256:
257: : "lit ( -- addr )
258: r> r> dup count + aligned >r swap >r ;
259:
260: \ */MOD */ 17may93jaw
261:
262: \ !! I think */mod should have the same rounding behaviour as / - anton
263: : */mod ( n1 n2 n3 -- n4 n5 ) \ core star-slash-mod
264: >r m* r> sm/rem ;
265:
266: : */ ( n1 n2 n3 -- n4 ) \ core star-slash
267: */mod nip ;
268:
269: \ HEX DECIMAL 2may93jaw
270:
271: : decimal ( -- ) \ core
272: a base ! ;
273: : hex ( -- ) \ core-ext
274: 10 base ! ;
275: