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