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