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