1: \ four stack assembler 19jan94py
2:
3: Vocabulary asm4stack
4: Vocabulary asmdefs
5:
6: asm4stack also asmdefs also definitions Forth
7:
8: ' asm4stack Alias [A] immediate
9: ' Forth Alias [F] immediate
10: : :A asm4stack definitions Forth ;
11: : :D asmdefs definitions Forth ;
12:
13: \ assembly area setup 24apr94py
14:
15: Defer '2@
16: Defer '2!
17: Defer 'c!
18: Defer '!
19: Defer 'SF!
20: Defer 'F!
21: Defer 4here
22: Defer 4allot
23:
24: \ frame format:
25: \ { target addr, target length, host addr, framelink }
26:
27: : 4there 4here ;
28:
29: : op! '2! ;
30: : op, 4there op! 2 cells 4allot ;
31: : op@ '2@ ;
32: : caddr ; immediate
33: : waddr ; immediate
34: : laddr ; immediate
35: [THEN]
36:
37: \ instruction generation 24apr94py
38:
39: 2Variable ibuf 0. ibuf 2!
40: Variable instfield 0 instfield !
41: Variable condfield 0 condfield !
42: Variable lastmove 0 lastmove !
43:
44: Create instmasks $003FFFFF.FFFFFFFF , ,
45: $FFC00FFF.FFFFFFFF , ,
46: $FFFFF003.FFFFFFFF , ,
47: $FFFFFFFC.00FFFFFF , ,
48: $FFFFFFFF.FF003FFF , ,
49: $FFFFFFFF.FFFFC00F , ,
50:
51: : instshift ( 10bit -- 64bit )
52: 1 5 instfield @ - &10 * 4 + $20 /mod >r
53: lshift um* r> IF swap THEN ;
54:
55: : 2and ( d1 d2 -- d ) rot and -rot and swap ;
56: : 2or ( d1 d2 -- d ) rot or -rot or swap ;
57:
58: : !inst ( 10bit -- ) instshift
59: instfield @ 2* cells instmasks + 2@ ibuf 2@ 2and 2or ibuf 2!
60: 1 instfield +! ;
61:
62: : finish ( -- ) ibuf 2@ op,
63: 0 0 ibuf 2! instfield off condfield off lastmove off ;
64: : finish? instfield @ IF finish THEN ;
65: :A
66: : ;; ( -- ) finish? postpone \ ;
67: : .org ( n -- ) 4here - 4allot ;
68: :D
69:
70: \ checks for instruction slots 19jan94py
71:
72: : alu? ( -- flag ) instfield @ 0 4 within ;
73: : move? ( -- flag ) instfield @ 4 6 within
74: ibuf cell+ @ 3 and 1 <> and ;
75: : call? ( -- flag ) instfield @ 4 < ;
76: : br? ( -- flag ) instfield @ 5 < ;
77:
78: : ?finish ( -- ) instfield @ 6 = IF finish THEN ;
79:
80: \ automatic feed of instructions 19jan94py
81:
82: Variable lastalu
83: Variable lastalufield
84:
85: : !alu ( 10bit -- )
86: alu? 0= IF finish THEN
87: dup lastalu !
88: instfield @ lastalufield !
89: !inst ;
90:
91: : !data ( 10bit -- ) alu? IF 4 instfield ! THEN
92: move? 0= IF finish 4 instfield ! THEN
93: instfield @ lastmove ! !inst ;
94:
95: : !br ( 10bit likelyhood -- addr )
96: br? 0= abort" No Data in Branch!"
97: alu? IF 4 instfield ! THEN >r !inst
98: ibuf 2@ 2 r> 3 and 2* 2* + 0 2or ibuf 2! 4here ;
99: :A
100: : do ( -- addr ) 0 0 !br finish ;
101: : br ( -- addr ) $200 1 !br ;
102:
103: : br,0 ( -- addr ) $200 0 !br ;
104: : br,1 ( -- addr ) $200 1 !br ;
105:
106: : call ( -- addr ) call? 0= IF finish THEN
107: 6 instfield ! ibuf 2@ $0.00000003 2or ibuf 2! 4here ;
108: : jmp ( -- addr ) call? 0= IF finish THEN
109: 6 instfield ! ibuf 2@ $1.00000003 2or ibuf 2! 4here ;
110:
111: : calla ( -- addr ) call? 0= IF finish THEN
112: 6 instfield ! ibuf 2@ $2.00000003 2or ibuf 2! 4here ;
113: : jmpa ( -- addr ) call? 0= IF finish THEN
114: 6 instfield ! ibuf 2@ $3.00000003 2or ibuf 2! 4here ;
115: :D
116:
117: \ branch conditions 20mar94py
118:
119: Create and/or-tab
120: $08 c, $04 c, $02 c, $01 c,
121: $1C c, $1A c, $19 c, $16 c, $15 c, $13 c,
122: $1E c, $1D c, $1B c, $17 c,
123: $1F c,
124: $0C c, $0A c, $09 c, $06 c, $05 c, $03 c,
125: $0E c, $0D c, $0B c, $07 c,
126: $0F c,
127:
128: : >and/or ( n -- stacks ) and/or-tab + c@ ;
129:
130: : constants 0 ?DO constant LOOP ;
131:
132: :A
133: hex
134: 9 8 7 6 5 4 6 constants 0&1 0&2 0&3 1&2 1&3 2&3
135: D C B A 4 constants 0&1&2 0&1&3 0&2&3 1&2&3
136: E constant 0&1&2&3
137:
138: 14 13 12 11 10 F 6 constants 0|1 0|2 0|3 1|2 1|3 2|3
139: 18 17 16 15 4 constants 0|1|2 0|1|3 0|2|3 1|2|3
140: 19 constant 0|1|2|3
141: decimal
142: :D
143:
144: \ branch conditions 20mar94py
145:
146: Create condmasks $FF07FFFF ,
147: $FFF83FFF ,
148: $FFFFC1FF ,
149: $FFFFFE0F ,
150:
151: : !cond ( n -- ) condfield @ 3 > abort" too much conds!"
152: $1F and 3 condfield @ - 5 * 4 + lshift
153: ibuf cell+ @ condmasks condfield @ cells + @ and or
154: ibuf cell+ ! 1 condfield +!
155: condfield @ 2/ 4 + instfield ! ;
156:
157: \ branch conditions 20mar94py
158:
159: : brcond ( n flag -- ) swap >and/or !cond !cond ;
160:
161: : cond: ( n -- ) Create ,
162: DOES> ( n/ -- ) @ ibuf cell+ @ 3 and
163: dup 2 = IF drop condfield @ dup 0=
164: IF drop brcond EXIT THEN
165: ELSE dup 0=
166: IF 1 ibuf cell+ +!
167: ELSE 1 <> THEN THEN
168: abort" Misplaced condition" !cond ;
169:
170: : conds: ( end start -- ) DO I cond: LOOP ;
171:
172: :A
173: $08 $00 conds: :t :0= :0< :ov :u< :u> :< :>
174: $10 $08 conds: :f :0<> :0>= :no :u>= :u<= :>= :<=
175: $18 $10 conds: ?t ?0= ?0< ?ov ?u< ?u> ?< ?>
176: $20 $18 conds: ?f ?0<> ?0>= ?no ?u>= ?u<= ?>= ?<=
177: :D
178:
179: \ loop/branch resolve 19mar94py
180:
181: : resolve! ( dist addr -- )
182: >r r@ op@ drop 3 and
183: dup 2 = IF drop $3FF8 and 0 ELSE
184: dup 3 = IF drop -8 and 0
185: r@ op@ nip 2 and IF swap r@ 8 + + swap THEN
186: ELSE true abort" No Jump!" THEN THEN
187: r@ op@ 2or r> op! ;
188:
189: :A
190: : .loop ( addr -- ) finish? dup >r 4here swap - 8 -
191: dup $2000 u>= abort" LOOP out of range!" r> resolve! ;
192: : .endif ( addr -- ) finish? dup >r 4here swap - 8 -
193: dup $1000 -$1000 within abort" BR out of range!"
194: r> resolve! ;
195:
196: : .begin ( -- addr ) finish? 4here ;
197: : .until ( addr1 addr2 -- ) finish? dup >r - 8 -
198: dup $1000 -$1000 within abort" BR out of range! "
199: r> resolve! ;
200:
201: : +IP ( addr1 rel -- ) finish? 8 * swap resolve! ;
202: : >IP ( addr1 addr -- ) finish? over 8 + - swap resolve! ;
203: :D
204:
205: \ labels 23may94py
206:
207: Vocabulary symbols
208: : symbols[ symbols definitions ;
209: : symbols] forth definitions ;
210:
211: Create makesym" ," label: " here $40 allot AConstant symname
212:
213: : sym-lookup? ( addr len -- xt/0 )
214: [ ' symbols >body ] ALiteral search-wordlist
215: 0= IF 0 THEN ;
216: : >sym" ( addr len -- ) symname swap move ;
217: : sym, ( addr len -- addr ) drop ;
218: \ symframe cell+ 2@ + swap ( --> addr target len )
219: \ 2dup aligned dup cell+ symframe cell+ +!
220: \ 2dup + >r cell+ erase move r> ( --> addr ) ;
221: : symbol, ( addr len -- xt ) dup >r
222: 2dup >sym" sym,
223: also asmdefs makesym" count r> + evaluate previous ;
224: : label: ( addr -- xt )
225: symbols[ Create symbols] 0 A, , lastxt
226: DOES> ( addr -- ) dup cell+ @ @ dup
227: IF nip >IP EXIT THEN
228: drop dup @ here rot ! A, , ;
229: : reveal: ( addr xt -- ) >body 2dup cell+ @ !
230: BEGIN @ dup WHILE
231: 2dup cell+ @ swap >IP REPEAT 2drop ;
232: :A
233: : .globl ( -- ) 0 bl word count symbol, ;
234: :D
235:
236: : is-label? ( addr u -- flag ) drop c@ '@ >= ;
237: : ?label ( addr u -- )
238: 2dup is-label?
239: IF 2dup 1- + c@ ': = dup >r +
240: 2dup sym-lookup? dup 0=
241: IF drop symbol, ELSE nip nip THEN
242: r@ IF finish? 4here over reveal: THEN
243: r> 0= IF execute ELSE drop THEN EXIT
244: THEN
245: defers interpreter-notfound ;
246:
247: \ >call 09sep94py
248:
249: : >call call? 0= IF finish THEN 3 instfield ! ;
250:
251: \ simple instructions 19jan94py
252:
253: : alu: ( 10bit -- ) Create , DOES> @ !alu ;
254:
255: : readword ( -- )
256: BEGIN >in @ bl word count dup 0=
257: WHILE refill 2drop 2drop REPEAT 2drop >in ! ;
258:
259: : alus: ( start end step -- ) -rot swap
260: ?DO readword I alu:
261: \ s" --" compare
262: \ IF >in ! I alu: ELSE drop THEN
263: dup +LOOP drop ;
264:
265: :A
266: %0000001001 %0110001001 %100000
267: alus: or add addc mul
268: and sub subc umul
269: xor subr subcr pass
270:
271: \ s1p is default
272:
273: \ mul@ 19jan94py
274:
275: %0110100000 %0110110000 1
276: alus: mul@ mul<@ mulr@ mulr<@
277: -mul@ -mul<@ -mulr@ -mulr<@
278: mul@+ mul<@+ mulr@+ mulr<@+
279: -mul@+ -mul<@+ -mulr@+ -mulr<@+
280:
281: \ flag generation 19jan94py
282:
283: %0110110000 %0111000000 1
284: alus: t 0= 0< ov u< u> < >
285: f 0<> 0>= no u>= u<= >= <=
286:
287: \ T4 19jan94py
288:
289: %0111000000 %0111100000 1
290: alus: asr lsr ror rorc asl lsl rol rolc
291: ff1 popc lob loh extb exth hib hih
292: sp@ loops@ loope@ ip@ sr@ cm@ index@ flatch@
293: sp! loops! loope! ip! sr! cm! index! flatch!
294:
295: \ T5, floating point: 19jan94py
296:
297: %0111100000 %0111110000 1
298: alus: fadd fsub fmul fnmul
299: faddadd faddsub fmuladd fmulsub
300: fi2f fni2f fadd@ fmul@
301: fs2d fd2s fxtract fiscale
302:
303: \ %0111110000 %0111110100 1
304: \ alus: ext extu mak clr
305:
306: %0111110000 %0111110010 1 alus: bfu bfs
307: %0111110100 %0111110110 1 alus: cc@ cc!
308:
309: %0111111000 %1000000000 1
310: alus: px1 px2 px4 px8
311: pp1 pp2 pp4 pp8
312: :D
313:
314: \ Stack effects 19jan94py
315:
316: : >curstack ( 5bit -- 5bit ) lastalufield @ 2* 2* xor ;
317:
318: : >stack ( alu -- ) lastalufield @
319: dup 1+ instfield @ <> ABORT" Spurious stack address!"
320: instfield ! !alu ;
321:
322: \ pick and pin 21jan94py
323:
324: : pin, ( 5bit -- ) dup %10000 and
325: IF >curstack dup %11 and swap %01100 and
326: ELSE dup %11 and %100 + swap %10000 %01100 within
327: THEN ABORT" Only current stack!"
328: %0110000000 or >stack ;
329:
330: : pick, ( 5bit -- )
331: dup %00000 %00100 within ABORT" No constant"
332: %0110000000 or >stack ;
333:
334: :A
335: %0110000000 alu: pin
336:
337: : pick ( -- )
338: alu? 0= IF finish THEN
339: instfield @ lastalufield ! %0110010000 >curstack !alu ;
340: :D
341:
342: \ Stack addresses 21jan94py
343:
344: : !stack ( 5bit -- )
345: lastalu @ %0110000000 = IF pin, EXIT THEN
346: lastalu @ %0110010000 >curstack = IF pick, EXIT THEN
347: lastalu @ %11111 and %01001 <> ABORT" Only one address!"
348: lastalu @ %1111100000 and or
349: dup %0110000000 u>= ABORT" no ALU instruction!" >stack ;
350:
351: : stack: ( 5bit -- ) Create , DOES> @ !stack ;
352:
353: : stacks: ( n -- )
354: 0 ?DO readword I stack: LOOP ;
355:
356: :A
357: $20 stacks: #0 #-1 #$7FFFFFFF #$80000000
358: c0 c1 c2 c3
359: s0p s1p s2p s3p
360: s4 s5 s6 s7
361: 0s0 0s1 0s2 0s3
362: 1s0 1s1 1s2 1s3
363: 2s0 2s1 2s2 2s3
364: 3s0 3s1 3s2 3s3
365: :D
366:
367: \ relativ to current stack 21jan94py
368:
369: : curstack: ( 5bit -- )
370: Create , DOES> @ >curstack !stack ;
371:
372: :A
373: %10000 curstack: s0
374: %10001 curstack: s1
375: %10010 curstack: s2
376: %10011 curstack: s3
377:
378: \ Abbrevations 21jan94py
379:
380: ' #$7FFFFFFF Alias #max
381: ' #$80000000 Alias #min
382:
383: \ FP abbrevations 21jan94py
384:
385: [A]
386: : fabs and #max ;
387: : fneg xor #min ;
388: : f2* add c3 ;
389: : f2/ sub c3 ;
390:
391: \ ALU abbrevations 21jan94py
392:
393: : nop or #0 ;
394: : not xor #-1 ;
395: : neg subr #0 ;
396: : inc sub #-1 ;
397: : dec add #-1 ;
398:
399: \ Stack abbrevations 21jan94py
400:
401: : dup pick s0 ;
402: : over pick s1 ;
403: : swap pick s1p ;
404: : rot pick s2p ;
405: : drop pin s0 ;
406: : nip pin s1 ;
407:
408: \ ret 19mar94py
409:
410: : ret ( -- ) >call ip! ;
411:
412: [F]
413: :D
414:
415: \ Literals 21mar94py
416:
417: : !a/d ( 10bit -- ) ?finish
418: alu? IF $200 or !alu ELSE !data THEN ;
419: Create lits 0. 2, 0. 2, 0. 2, 0. 2, 0. 2, 0. 2,
420:
421: :A
422: : # ( 8bit -- ) dup $80 -$80 within abort" out of range"
423: $FF and !a/d ;
424: : #< ( 8bit -- ) dup $100 0 within abort" out of range"
425: $100 or !a/d ;
426:
427: : ## ( 32bit -- ) ?finish 3
428: BEGIN over $FF800000 and dup $FF800000 = swap 0= or WHILE
429: 1- swap 8 lshift swap dup 0= UNTIL THEN
430: swap $100 um* dup $80 and negate or >r
431: swap lits instfield @ 2* cells + 2! r> [A] # [F] ;
432:
433: : #, ( -- ) ?finish lits instfield @ 2* cells + dup 2@ dup 0>
434: IF over 0= alu? and
435: IF dup 3 = IF hib 2drop 0 0 rot 2! EXIT THEN
436: dup 2 = IF hih 2drop 0 0 rot 2! EXIT THEN THEN
437: 1- >r $100 um* #< r> rot 2!
438: ELSE 2drop drop alu? IF nop ELSE 0 # THEN THEN ;
439: :D
440:
441: : >ip.b ( -- )
442: bl word count sym-lookup? dup 0= abort" No symbol!"
443: >body cell+ @ @ 4here 2 cells + - ;
444: :A
445: : .ip.b# ( -- ) >ip.b [A] # [F] ;
446: : .ip.h# ( -- ) >ip.b 2/ [A] # [F] ;
447: : .ip.w# ( -- ) >ip.b 2/ 2/ [A] # [F] ;
448: : .ip.2# ( -- ) >ip.b 2/ 2/ 2/ [A] # [F] ;
449: : .ip.4# ( -- ) >ip.b 2/ 2/ 2/ 1+ 2/ [A] # [F] ;
450: ' .ip.2# alias .ip.d#
451: ' .ip.2# alias .ip.f#
452: ' .ip.4# alias .ip.q#
453: ' .ip.4# alias .ip.2f#
454: :D
455: Variable procstart
456: : >p.b ( -- )
457: bl word count sym-lookup? dup 0= abort" No symbol!"
458: >body cell+ @ @ procstart @ - ;
459: :A
460: : .proc finish? 4here procstart ! ;
461: : .p ( -- n ) >p.b ;
462: : .p.b# ( -- ) >p.b [A] # [F] ;
463: : .p.h# ( -- ) >p.b 2/ [A] # [F] ;
464: : .p.w# ( -- ) >p.b 2/ 2/ [A] # [F] ;
465: : .p.2# ( -- ) >p.b 2/ 2/ 2/ [A] # [F] ;
466: : .p.4# ( -- ) >p.b 2/ 2/ 2/ 2/ [A] # [F] ;
467: ' .p.2# alias .p.d#
468: ' .p.2# alias .p.f#
469: ' .p.4# alias .p.q#
470: ' .p.4# alias .p.2f#
471: : .p.b## ( -- ) >p.b [A] ## [F] ;
472: : .p.h## ( -- ) >p.b 2/ [A] ## [F] ;
473: : .p.w## ( -- ) >p.b 2/ 2/ [A] ## [F] ;
474: : .p.2## ( -- ) >p.b 2/ 2/ 2/ [A] ## [F] ;
475: : .p.4## ( -- ) >p.b 2/ 2/ 2/ 2/ [A] ## [F] ;
476: ' .p.2## alias .p.d##
477: ' .p.2## alias .p.f##
478: ' .p.4## alias .p.q##
479: ' .p.4## alias .p.2f##
480: :D
481:
482: \ data instructions 20mar94py
483:
484: : cu ( -- n ) instfield @ 1- 1 and IF 4 ELSE 8 THEN ;
485: : move: ( n -- ) Create ,
486: DOES> @ !data cu ibuf cell+ tuck @ or swap ! ;
487: : moves: -rot ?DO I move: dup +LOOP drop ;
488:
489: :A
490: %0010000000 %0000000000 %100000 moves: ldb ldh ld ld2
491: %1010000000 %1000000000 %100000 moves: stb sth st st2
492:
493: ' ld2 Alias ldf
494: ' ld2 Alias ldq
495: ' st2 Alias stf
496: ' st2 Alias stq
497: :D
498:
499: \ data instructions 22mar94py
500:
501: : ua: ( n -- ) Create , DOES> @ !data ;
502: : uas: ( e s i -- ) -rot ?DO i ua: dup +LOOP drop ;
503:
504: :A
505: %1000010000 %1000000000 %100 uas: R0= R1= R2= R3=
506: %1001000000 ua: get
507: %1001010000 ua: set
508: %1001100000 ua: getd
509: %1001110000 ua: setd
510:
511: %1010010000 %1010000000 %100 uas: ccheck cclr cstore cflush
512: %1010100000 %1010010100 %100 uas: cload calloc cxlock
513:
514: %1010011000 %1010010000 %100 uas: mccheck mdcheck
515: %1010011100 %1010011000 %001 uas: mcget mcset mchif mclof
516: %1010100000 %1010011100 %001 uas: mdget mdset mdhif mdlof
517:
518: %1011100000 %1011000000 %100 uas: inb inh in ind outb outh out outd
519: %1011000011 %1011000001 %1 uas: inq ins
520:
521: %1011100100 %1011100000 %1 uas: =c0 =c1 =c2 =c3
522:
523: %1011101000 ua: geta
524: %1011111000 ua: seta
525: %1011101100 ua: getdrn
526: %1011111100 ua: setdrn
527: %1111101100 ua: getdmf
528: %1111111100 ua: setdmf
529:
530: %1011100100 ua: getc
531: %1011110100 ua: setc
532: %1011100101 ua: stop
533: %1011110101 ua: restart
534: %1011100110 ua: stop1
535: %1011110110 ua: restart1
536: %1011100111 ua: halt
537:
538: :D
539:
540: \ data instructions 20mar94py
541:
542: : |inst ( 10bit n -- )
543: dup 0= abort" Only after moves!"
544: instfield @ >r instfield !
545: instshift ibuf 2@ 2or ibuf 2! r> instfield ! ;
546: : mode: Create , DOES> @ lastmove @ |inst ;
547:
548: : modes: DO I mode: 4 +LOOP ;
549: : regs: DO I mode: LOOP ;
550:
551: :A
552: $10 $04 modes: +N N+ +N+
553: $20 $14 modes: +s0 s0+ +s0+
554:
555: $10 $00 regs: R0 R1 R2 R3 N0 N1 N2 N3 L0 L1 L2 L3 F0 F1 F2 F3
556: $14 $10 regs: ip s0b ip+s0 s0l
557: :D
558:
559: \ data instructions 22mar94py
560:
561: : ua-only true abort" Only for update!" ;
562: : umode: >in @ >r name sfind r> >in ! Create
563: 0= IF ['] ua-only THEN swap , ,
564: DOES> dup @ lastmove @ 1 and IF 4 ELSE 8 THEN
565: ibuf cell+ @ and IF drop cell+ @ execute EXIT THEN
566: lastmove @ |inst drop ;
567:
568: :A
569: %0100000000 umode: +N
570: %0000010000 umode: +s0
571: %0000100000 umode: -N
572: %0000110000 umode: -s0
573: :D
574:
575: \ data instructions 20mar94py
576:
577: : stevnop: ( n -- ) Create ,
578: DOES> @ lastmove @ 4 <> abort" Only even stacks!" 4 |inst ;
579: : stoddop: ( n -- ) Create ,
580: DOES> @ lastmove @ 5 <> abort" Only odd stacks!" 5 |inst ;
581:
582: : stevnops: ( end start disp -- ) -rot
583: DO I stevnop: dup +LOOP drop ;
584: : stoddops: ( end start disp -- ) -rot
585: DO I stoddop: dup +LOOP drop ;
586:
587: :A
588: %1000000000 %0000000000 %0010000000 stevnops: 0: 0&2: 2: 2&0:
589: %1000000000 %0000000000 %0010000000 stoddops: 1: 1&3: 3: 3&1:
590: :D
591:
592: \ data definition instructions 24apr94py
593:
594: Defer normal-mode
595: Defer char-mode
596:
597: : number-mode ( n dest char -- n' dest' )
598: \ ." Number: " dup emit cr
599: dup toupper digit?
600: IF nip rot base @ * + dup $10000 >=
601: IF normal-mode $100 THEN swap EXIT THEN
602: >r tuck caddr 'c! 1+ $100 swap r> normal-mode ;
603:
604: : esc-mode ( dest char -- dest' )
605: \ ." Escape: " dup emit cr
606: dup 'n = IF drop #lf normal-mode EXIT THEN
607: dup 't = IF drop #tab normal-mode EXIT THEN
608: dup 'x = IF drop hex ['] number-mode IS char-mode EXIT THEN
609: dup '0 '8 within
610: IF 8 base ! ['] number-mode IS char-mode char-mode EXIT THEN
611: $100 + normal-mode ;
612:
613: : (normal-mode) ( dest char -- dest' )
614: \ ." Char : " dup emit cr
615: dup '\ = IF drop ['] esc-mode IS char-mode EXIT THEN
616: over caddr 'c! 1+ ['] normal-mode IS char-mode ;
617: ' (normal-mode) IS normal-mode
618:
619: : \move ( addr len dest -- dest+n )
620: base @ >r ['] normal-mode IS char-mode
621: $100 swap 2swap bounds ?DO I c@ char-mode LOOP
622: over $FF and 0> IF tuck caddr 'c! 1+ ELSE nip THEN
623: r> base ! ;
624:
625: : byte, 4there caddr 'c! 1 4allot ;
626: : short, $100 /mod 4there waddr 'c!
627: 4there waddr 1+ 'c! 2 4allot ;
628: : int, 4there laddr '! 1 cells 4allot ;
629: : long, 4there laddr '! 1 cells 4allot ;
630: : quad, op, ;
631: \ : float, 4there laddr 'SF! 1 cells 4allot ;
632: \ : double, 4there 'F! 1 floats 4allot ;
633:
634: : ascii, 4there \move 4there - 4allot ;
635:
636: :A
637: : .align ( "n[,m]" -- ) 0 0 name >number
638: dup IF over c@ ', =
639: IF 1 /string parser 0 0 THEN THEN
640: 2drop 1 rot lshift 4here over 1- >r - r> and
641: 0 ?DO dup 4there caddr 'c! 1 4allot LOOP drop ;
642:
643: : .( ') parse also Forth evaluate previous ;
644:
645: : .byte name parser byte, ;
646: : .short name parser short, ;
647: : .int name parser int, ;
648: : .long name parser long, ;
649: : .quad name s>number dpl @ 0= abort" Not a number" quad, ;
650: \ : .float name >float 0= abort" Not a FP number" float, ;
651: \ : .double name >float 0= abort" Not a FP number" double, ;
652:
653: : .ascii '" parse 2drop
654: source >in @ /string over swap
655: BEGIN '" scan over 1- c@ '\ = over 0<> and WHILE
656: 1 /string REPEAT >r
657: over - dup r> IF 1+ THEN >in +! ascii, ;
658:
659: : .macro finish? also asmdefs also asm4stack definitions
660: : ;
661: : .end-macro postpone ; previous previous ; immediate restrict
662:
663: : .include include ;
664:
665: : .times{ ( n -- input n )
666: dup >r 1 > IF save-input THEN r> ;
667: : .}times ( input n -- input n-1 / 1 / )
668: 1- dup 0>
669: IF >r restore-input throw r@ 1 >
670: IF save-input THEN r>
671: THEN ;
672: :D
673:
674: \ save assembler output 25apr94py
675:
676: : (fdump ( handle link -- ) 2dup >r swap
677: 3 cells + @ dup IF recurse ELSE 2drop THEN
678: r@ cell+ @ 0= IF rdrop drop EXIT THEN
679: \ cr ." Writing " r@ @ . ." len " r@ cell+ @ .
680: r@ cell+ @ 7 + -8 and r@ cell+ !
681: r@ 2 cells 2 pick write-file throw
682: r@ cell+ cell+ @ dup 7 and 2 = IF 2drop rdrop EXIT THEN
683: r> cell+ @ rot write-file throw ;
684:
685: Create 4magic ," 4stack00"
686:
687: \ end of assembler
688:
689: Variable old-notfound
690:
691: :A
692: : F' ' ;
693:
694: also Forth definitions
695:
696: : (code)
697: also asm4stack
698: s" F' 2@ F' 2! F' c! F' ! F' here F' allot" evaluate
699: IS 4allot IS 4here IS '! IS 'c! IS '2! IS '2@
700: What's interpreter-notfound old-notfound !
701: ['] ?label IS interpreter-notfound ;
702: : label (code) 4here label: drop asm4stack depth ;
703: : (end-code) previous old-notfound @ IS interpreter-notfound ;
704:
705: previous previous previous Forth
706:
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to asm.fs CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [gforth] / gforth / arch / 4stack