1: \ 4stack primitives
2:
3: \ Copyright (C) 2000 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., 59 Temple Place, Suite 330, Boston, MA 02111, USA.
20:
21: Label start ;;
22: nop ;; first opcode must be a nop!
23: $80000000 ## ;;
24: #, ;;
25: sr! jmpa $828 >IP ;;
26:
27: $800 .org
28: ip0: .int 0
29: .int 0
30: conpat: nop nop ip@ jmpa ;;
31: varpat: nop nop ip@ jmpa ;;
32: jmppat: nop ip@ nop jmpa ;;
33: colpat: nop nop ip@ jmpa ;;
34: ;; ds cfa fs rs
35: main: ;;
36: -$200 ## nop nop nop -12 # ld 1: ip ;;
37: #, nop nop nop set 0: R3 ;;
38: nop nop nop nop 0 # set 1: R1 ;;
39: nop nop nop nop 0 # ld 1: R1 N+ ;;
40: nop nop nop nop 0 # ld 1: R1 N+ ;;
41: nop ip! nop nop 0 # ld 1: R1 N+ ;;
42: nop ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
43:
44: docol: .endif ;;
45: ;; nop nop ip@ jmp docol ;;
46: ;; ds ca cfa fs rs
47: nop 8 # drop -12 # get 0: R1 get 3: R1 ;;
48: drop add 0s0 nop add 0 # set 1: R1 ;;
49: nop drop nop nop 0 # ld 1: R1 N+ ;;
50: nop drop nop nop 0 # ld 1: R1 N+ ;;
51: nop ip! nop nop 0 # ld 1: R1 N+ ;;
52: nop ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
53: dodoes: .endif ;;
54: ;; nop nop ip@ jmp doesjump
55: ;; nop ip@ nop jmp dodoes
56: ;; ds df ca cfa fs rs
57: 8 # nop drop -12 # get 0: R1 get 3: R1 ;;
58: add nop nop add 0 # set 1: R1 ;;
59: nop drop nop nop 0 # ld 1: R1 N+ ;;
60: nop drop nop nop 0 # ld 1: R1 N+ ;;
61: nop ip! nop nop 0 # ld 1: R1 N+ ;;
62: nop ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
63: dovar: .endif ;;
64: ;; nop nop ip@ jmp dovar ;;
65: ;; ds cfa fs rs
66: 8 # swap ip! nop get 0: R1 ;;
67: add ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
68:
69: docon: .endif ;;
70: ;; nop nop ip@ jmp dovar ;;
71: ;; ds cfa fs rs
72: nop swap ip! nop ld 0: R1 2 # ;;
73: nop ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
74: end-code
75:
76: -3 Alias: :docon
77:
78: Code execute ( xt -- )
79: nop nop nop ip@ br .endif
80: ip! drop pick 0s0 nop set 2: R1 ;;
81: nop nop nop ip! -1 # ld 1: R1 ;;
82: end-code
83:
84: Code ?branch
85: nop nop nop ip@ br .endif
86: nop swap nop nop br 0 ?0<>
87: nop nop nop nop -12 # R1= R1 3: +s0 ;;
88: nop drop nop nop 0 # ld 1: R1 N+ ;;
89: nop drop nop nop 0 # ld 1: R1 N+ ;;
90: .endif
91: nop ip! nop drop 0 # ld 1: R1 N+ ;;
92: nop ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
93: end-code
94:
95: Code +
96: add ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
97: end-code
98:
99: Code and
100: and ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
101: end-code
102:
103: Code xor
104: xor ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
105: end-code
106:
107: Code sp@
108: sp@ ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
109: end-code
110:
111: Code sp!
112: sp! ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
113: end-code
114:
115: Code rp@
116: nop nop ip@ sp@ br .endif
117: pick 3s0 swap ip! drop ;;
118: nop ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
119: end-code
120:
121: Code rp!
122: drop nop ip@ pick 0s0 br .endif
123: nop swap ip! sp! ;;
124: nop ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
125: end-code
126:
127: Code ;s
128: nop nop nop nop br .endif
129: nop drop nop nop 0 # set 3: R1 ;;
130: nop drop nop nop 0 # ld 1: R1 N+ ;;
131: nop nop nop nop 0 # ld 1: R1 N+ ;;
132: nop ip! nop nop 0 # ld 1: R1 N+ ;;
133: nop ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
134: end-code
135:
136: Code @
137: nop nop ip@ nop br .endif
138: drop swap ip! nop ld 0: s0b 0 # ;;
139: nop ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
140: end-code
141:
142: Code !
143: nop nop ip@ nop br .endif
144: drop swap ip! nop st 0: s0b 0 # ;;
145: nop ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
146: end-code
147:
148: \ obligatory IO
149:
150: Code key?
151: nop nop ip@ nop br .endif
152: nop swap nop nop inb R3 3 # ;;
153: nop nop ip! nop ;;
154: 0<> ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
155: end-code
156:
157: Code (key)
158: nop nop ip@ nop br .endif
159: .begin inb R3 3 # ;;
160: nop br 0 ?0= .until
161: inb R3 2 # ;;
162: nop swap ip! nop ;;
163: nop ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
164: end-code
165:
166: Code (emit)
167: nop nop ip@ nop br .endif
168: ;; .begin inb R3 1 # ;;
169: ;; nop br 0 ?0= .until
170: outb 0: R3 0 # ;;
171: nop swap ip! nop ;;
172: nop ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
173: end-code
174:
175: : (type)
176: bounds ?DO I c@ (emit) LOOP ;
177: \ BEGIN dup WHILE
178: \ >r dup c@ (emit) 1+ r> 1- REPEAT 2drop ;
179:
180: \ obligatory code address manipulations
181:
182: : >code-address ( xt -- addr ) cell+ @ -8 and ;
183: : >does-code ( xt -- addr )
184: cell+ @ -8 and \ dup 3 and 3 <> IF drop 0 EXIT THEN
185: 8 + dup cell - @ 3 and 0<> and ;
186: : code-address! ( addr xt -- ) >r 3 or $808 @ r> 2! ;
187: : does-code! ( a_addr xt -- ) >r 5 - $808 @ r> 2! ;
188: : does-handler! ( a_addr -- ) $818 2@ rot 2! ;
189:
190: \ this was obligatory, now some things to speed it up
191:
192: Code 2/
193: asr ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
194: end-code
195:
196: Code branch
197: nop nop nop ip@ br .endif
198: nop nop nop nop -12 # R1= R1 3: +s0 ;;
199: nop drop nop nop 0 # ld 1: R1 N+ ;;
200: nop drop nop nop 0 # ld 1: R1 N+ ;;
201: nop ip! nop drop 0 # ld 1: R1 N+ ;;
202: nop ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
203: end-code
204:
205: Code (loop)
206: pick 3s1 nop nop ip@ br .endif
207: dec nop nop nop ;;
208: sub 3s1 swap nop nop br 0 ?0=
209: nop nop nop nop -12 # R1= R1 3: +s0 ;;
210: nop drop nop nop 0 # ld 1: R1 N+ ;;
211: nop drop nop nop 0 # ld 1: R1 N+ ;;
212: .endif
213: nop ip! nop drop 0 # ld 1: R1 N+ ;;
214: nop ip! ip@ inc set 2: R1 ld 1: R1 N+ ;;
215: end-code
216:
217: Code (+loop)
218: pick 3s1 nop nop ip@ br .endif
219: subr 3s1 nop nop nop ;;
220: xor #min nop nop nop ;;
221: add s1 swap nop nop br 0 ?ov
222: nop nop nop nop -12 # R1= R1 3: +s0 ;;
223: nop drop nop nop 0 # ld 1: R1 N+ ;;
224: nop drop nop nop 0 # ld 1: R1 N+ ;;
225: .endif
226: nop ip! nop drop 0 # ld 1: R1 N+ ;;
227: drop ip! ip@ add 0s0 set 2: R1 ld 1: R1 N+ ;;
228: end-code
229:
230: Code (do)
231: nop nop ip@ nop br .endif
232: nip swap ip! pick 0s1 ;;
233: drop ip! ip@ pick 0s0 set 2: R1 ld 1: R1 N+ ;;
234: end-code
235:
236: Code -
237: subr ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
238: end-code
239:
240: Code or
241: or ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
242: end-code
243:
244: Code 1+
245: inc ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
246: end-code
247:
248: Code 2*
249: asl ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
250: end-code
251:
252: Code cell+
253: add c2 ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
254: end-code
255:
256: Code cells
257: nop nop ip@ nop br .endif
258: asl swap ip! nop ;;
259: asl ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
260: end-code
261:
262: Code c@
263: nop nop ip@ nop br .endif
264: drop swap ip! nop ldb 0: s0b 0 # ;;
265: nop ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
266: end-code
267:
268: Code c!
269: nop nop ip@ nop br .endif
270: drop swap ip! nop stb 0: s0b 0 # ;;
271: nop ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
272: end-code
273:
274: Code um*
275: nop nop ip@ nop br .endif
276: umul swap ip! nop ;;
277: mul@ ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
278: end-code
279:
280: Code m*
281: nop nop ip@ nop br .endif
282: mul swap ip! nop ;;
283: mul@ ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
284: end-code
285:
286: Code d+
287: nop nop ip@ nop br .endif
288: pass swap ip! nop ;;
289: mul@+ ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
290: end-code
291:
292: Code >r
293: drop ip! ip@ pick 0s0 set 2: R1 ld 1: R1 N+ ;;
294: end-code
295:
296: Code r>
297: pick 3s0 ip! ip@ drop set 2: R1 ld 1: R1 N+ ;;
298: end-code
299:
300: Code drop
301: drop ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
302: end-code
303:
304: Code swap
305: swap ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
306: end-code
307:
308: Code over
309: over ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
310: end-code
311:
312: Code 2dup
313: nop nop ip@ nop br .endif
314: over swap ip! nop ;;
315: over ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
316: end-code
317:
318: Code rot
319: rot ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
320: end-code
321:
322: Code -rot
323: nop nop ip@ nop br .endif
324: rot swap ip! nop ;;
325: rot ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
326: end-code
327:
328: Code i
329: pick 3s0 ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
330: end-code
331:
332: Code i'
333: pick 3s1 ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
334: end-code
335:
336: Code j
337: pick 3s2 ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
338: end-code
339:
340: Code lit
341: ip@ nop pick 1s0 nop br .endif ;;
342: nop nip ip! nop 0 # ld 1: R1 N+ ;;
343: nop ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
344: end-code
345:
346: Code 0=
347: 0= ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
348: end-code
349:
350: Code 0<>
351: 0<> ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
352: end-code
353:
354: Code u<
355: nop nop ip@ nop br .endif
356: subr swap ip! nop ;;
357: u< ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
358: end-code
359:
360: Code u>
361: nop nop ip@ nop br .endif
362: subr swap ip! nop ;;
363: u> ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
364: end-code
365:
366: Code u>=
367: nop nop ip@ nop br .endif
368: subr swap ip! nop ;;
369: u>= ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
370: end-code
371:
372: Code u<=
373: nop nop ip@ nop br .endif
374: subr swap ip! nop ;;
375: u<= ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
376: end-code
377:
378: Code >=
379: nop nop ip@ nop br .endif
380: subr swap ip! nop ;;
381: >= ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
382: end-code
383:
384: Code <=
385: nop nop ip@ nop br .endif
386: subr swap ip! nop ;;
387: <= ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
388: end-code
389:
390: Code =
391: nop nop ip@ nop br .endif
392: subr swap ip! nop ;;
393: 0= ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
394: end-code
395:
396: Code <>
397: nop nop ip@ nop br .endif
398: subr swap ip! nop ;;
399: 0<> ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
400: end-code
401:
402: \ : (find-samelen) ( u f83name1 -- u f83name2/0 )
403: \ BEGIN 2dup cell+ c@ $1F and <> WHILE @ dup 0= UNTIL THEN ;
404: Code (find-samelen)
405: nop nop ip@ nop br .endif
406: nop 0 # 0 # nop ;;
407: nop nop pick 0s0 nop ;;
408: .begin
409: drop drop nop nop ldb 0: s0b 4 # ;;
410: nop $1F # nip nop ld 2: s0b 0 # ;;
411: drop and 0s0 nop nop ;;
412: pick 2s0 sub 0s0 nop nop br 1&2 :0<> .until ;;
413: pick 2s1 nop pass nop br 1 ?0= ;;
414: drop swap ip! nop ;;
415: nop ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
416: .endif
417: nip swap ip! nop ;;
418: nop ip! ip@ nop set 2: R1 ld 1: R1 N+ ;;
419: end-code
420:
421: \ division a/b
422: \ x:=a, y:=b, r:=est; iterate(x:=x*r, y:=y*r, r:=2-y*r);
423: \ result: x=a/b; y=1; r=1
424:
425: \ Label idiv-table
426: \ idiv-tab:
427: \ .macro .idiv-table [F]
428: \ $100 $80 DO 0 $100 I 2* 1+ um/mod long, drop LOOP
429: \ .end-macro
430: \ .idiv-table
431: \ end-code
432: \
433: \ Code um/mod1 ( u -- 1/u )
434: \ ;; b -- -- -- -- -- ;;
435: \ ff1 -$1F # nop nop br 0 :0= div0
436: \ bfu add 0s0 ip@ nop set 2: R2 ;;
437: \ ;; b' -- -- -- -- -- ;;
438: \ lob $0FF ## pick 0s0 pick 0s0 0 # -$108 ## ;;
439: \ 1 # #, sub #min 1 # ld 0: R2 +s0 #, ;;
440: \ cm! and nop cm! br 2 ?0= by2
441: \ ;; est -- -- b' -- -- ;;
442: \ umul 3s0 pick 0s0 nop umul 0s0 0 # 0 # ;;
443: \ mulr<@ nop nop -mulr@ ;;
444: \ drop umul 3s0 nop umul 0s0 ;;
445: \ mulr<@ cm! nop -mulr@ ;;
446: \ umul 3s0 drop pick 1s0 drop ;;
447: \ drop mulr<@ ip! nop 0 # ld 1: R1 N+ ;;
448: \ pick 1s0 drop nop nop ;;
449: \ by2:
450: \ div0:
451: \ -1 # ip! nop nop 0 # ld 1: R1 N+ ;;
452: \ nop nop nop nop ;;
453: \ end-code
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to prim-new.fs CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [gforth] / gforth / arch / 4stack