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