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