Annotation of gforth/arch/4stack/asm.fs, revision 1.1
1.1 ! pazsan 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, 4there '2! 2 cells 4allot ;
! 30: : op! '2! ;
! 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 also
! 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 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