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