urflibs/urasm/emit.f

   1 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   2 ;; and now for something completely different...
   3 ;; UrAsm Forth Engine!
   4 ;; GPLv3 ONLY
   5 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   6 ;; Z80 Assembler: code emitter
   7 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   8
   9
  10 vocab-if-none asm-emit
  11 also-defs: asm-emit
  12
  13 bitmask-enum{
  14   def: zx-mflag-used
  15   def: zx-mflag-reserved
  16 }
  17
  18
  19 : init-memory  ( -- )
  20   zx-mem 65536 erase
  21   zx-mflags 65536 erase
  22 ;
  23
  24
  25 : used?  ( addr -- bool )
  26   dup 0x1_0000 u< swap zx-mflags + c@ zx-mflag-used and logand
  27 ;
  28
  29
  30 : find-used  ( from -- addr TRUE / FALSE )
  31   begin dup 0x1_0000 u< over used? not and while 1+ repeat
  32   dup 0x1_0000 u< if true else drop false endif
  33 ;
  34
  35 : find-unused  ( from -- addr TRUE / FALSE )
  36   begin dup 0x1_0000 u< over used? and while 1+ repeat
  37   dup 0x1_0000 u< if true else drop false endif
  38 ;
  39
  40
  41 ;; this is PC for "$"
  42 ;; main driver sets it before calling instruction words
  43 0 value pc$
  44 0 value pc
  45 0 value disp
  46 -1 value ent
  47 -1 value clr
  48
  49
  50 : instruction-start  ( -- )
  51   pc to pc$
  52 ;
  53
  54
  55 : .hex2    ( n -- )  base @ hex swap <# # # #> type base ! ;
  56 : .hex4    ( n -- )  base @ hex swap <# # # # # #> type base ! ;
  57 : .hex4-r  ( n -- )  dup .hex2 space -8 lsh .hex2 ;
  58
  59 ;; used in various unpackers (RLE, for example)
  60 ;; doesn't change flags
  61 : c!-if-free  ( value addr -- )
  62   dup 0x1_0000 u< if
  63     dup zx-mflags + c@ zx-mflag-used and ifnot
  64       zx-mem + c!
  65     else 2drop endif
  66   else 2drop endif
  67 ;
  68
  69 ;; doesn't change flags
  70 : cmove-from-normal  ( src zx-dest count -- )
  71   for
  72     dup 0x1_0000 u< if
  73       over c@ over zx-mem + c!
  74       1+ swap 1+ swap
  75     endif
  76   endfor 2drop
  77 ;
  78
  79 : here  ( -- addr )  disp ;
  80
  81 : or-c!  ( value addr -- )
  82   dup 65535 u> " invalid zx address" ?error
  83   dup zx-mflags + forth:c@ zx-mflag-used <> " trying to patch undefined zx memory address" ?error
  84   zx-mem + dup forth:c@ rot or swap forth:c!
  85 ;
  86
  87 : c!  ( value addr -- )
  88   dup 65535 u> " invalid zx address" ?error
  89   dup zx-mflags + forth:c@ zx-mflag-used <> " trying to patch undefined zx memory address" ?error
  90   zx-mem + forth:c!
  91 ;
  92
  93 : w!  ( value addr )  2dup c! 1+ swap -8 lsh swap c! ;
  94
  95
  96 : +1>pc  ( n -- )
  97   +1-to pc
  98   +1-to disp
  99 ;
 100
 101 : .pc  ( -- ) ." #" pc .hex4 ." : " ;
 102
 103 : (emit-byte)  ( byte -- )
 104   pc 65536 u> " zx memory overflow (pc)" ?error
 105   disp 65536 u> " zx memory overflow (disp)" ?error
 106   disp zx-mflags + forth:c@ zx-mflag-reserved and " trying to write to reserved memory" ?error
 107   disp zx-mem + forth:c!
 108   disp zx-mflags + dup forth:c@ zx-mflag-used or swap forth:c!
 109   +1>pc
 110 ;
 111
 112 : byte  ( byte -- )
 113   \ .pc dup .hex2 cr
 114   (emit-byte)
 115 ;
 116
 117 : neg-byte  ( byte -- )
 118   negate 0xff and
 119   \ .pc dup .hex2 cr
 120   (emit-byte)
 121 ;
 122
 123 : word  ( word -- )
 124   \ .pc dup .hex4-r cr
 125   dup (emit-byte) -8 lsh (emit-byte)
 126 ;
 127
 128 : addr  ( word -- )
 129   \ .pc dup .hex4-r cr
 130   dup (emit-byte) -8 lsh (emit-byte)
 131 ;
 132
 133
 134 : (im)  ( byte -- opcode )
 135   case
 136     0 of 0x46 endof
 137     1 of 0x56 endof
 138     2 of 0x5e endof
 139     otherwise " wtf?!" error
 140   endcase
 141 ;
 142
 143 : im  ( byte -- )  (im) byte ;
 144
 145 : rst  ( rst-addr -- )  0o307 or byte ;
 146 : rst-c!  ( rst-addr addr -- )  swap 0o307 or swap c! ;
 147
 148 : bit-c!  ( bitnum addr+1 -- )  swap 3 lsh swap 1- or-c! ;
 149
 150
 151 prev-defs