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