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