pic18.scm

   1 ;;; File: "pic18.scm"
   2
   3 (include "asm.scm")
   4
   5 (define-macro (bitmask encoding . field-values)
   6   (let loop ((i 0)
   7              (pos 0)
   8              (mask 0)
   9              (fields (list (list #\space 0 0))))
  10     (if (< i (string-length encoding))
  11         (let ((c (string-ref encoding i)))
  12           (cond ((char=? c #\0)
  13                  (loop (+ i 1)
  14                        (+ pos 1)
  15                        (* mask 2)
  16                        fields))
  17                 ((char=? c #\1)
  18                  (loop (+ i 1)
  19                        (+ pos 1)
  20                        (+ 1 (* mask 2))
  21                        fields))
  22                 ((char=? c #\space)
  23                  (loop (+ i 1)
  24                        pos
  25                        mask
  26                        fields))
  27                 (else
  28                  (if (and (char=? c (car (car fields)))
  29                           (= pos (caddr (car fields))))
  30                      (begin
  31                        (set-car! (cddr (car fields)) (+ pos 1))
  32                        (loop (+ i 1)
  33                              (+ pos 1)
  34                              (* mask 2)
  35                              fields))
  36                      (loop (+ i 1)
  37                            (+ pos 1)
  38                            (* mask 2)
  39                            (cons (list c pos (+ pos 1)) fields))))))
  40         (begin
  41           (if (not (= pos 16))
  42               (error "invalid bitmask" encoding))
  43           (cons '+
  44                 (cons mask
  45                       (map (lambda (f v)
  46                              (let* ((width (- (caddr f) (cadr f)))
  47                                     (shift (- pos (caddr f))))
  48                                (list 'bitfield
  49                                      encoding
  50                                      (string (car f))
  51                                      (expt 2 width)
  52                                      shift
  53                                      v)))
  54                            (cdr (reverse fields))
  55                            field-values)))))))
  56
  57 (define (bitfield encoding name limit shift value)
  58   (if (or (< value 0) (>= value limit))
  59       (error "value does not fit in field" name value encoding)
  60       (arithmetic-shift value shift)))
  61
  62 ;------------------------------------------------------------------------------
  63
  64 ; Byte-oriented file register operations.
  65
  66 (define (addwf f #!optional (d 'f) (a 'a))
  67   (make-instruction
  68    1
  69    (lambda ()
  70      (make-listing "addwf" (file-text f) (dest-text d 'f) (access-text a 'a)))
  71    (lambda ()
  72      (asm-16 (bitmask "0010 01da ffff ffff" (dest d) (access a) (file f))))))
  73
  74 (define (addwfc f #!optional (d 'f) (a 'a))
  75   (make-instruction
  76    1
  77    (lambda ()
  78      (make-listing "addwfc" (file-text f) (dest-text d 'f) (access-text a 'a)))
  79    (lambda ()
  80      (asm-16 (bitmask "0010 00da ffff ffff" (dest d) (access a) (file f))))))
  81
  82 (define (andwf f #!optional (d 'f) (a 'a))
  83   (make-instruction
  84    1
  85    (lambda ()
  86      (make-listing "andwf" (file-text f) (dest-text d 'f) (access-text a 'a)))
  87    (lambda ()
  88      (asm-16 (bitmask "0001 01da ffff ffff" (dest d) (access a) (file f))))))
  89
  90 (define (clrf f #!optional (a 'a))
  91   (make-instruction
  92    1
  93    (lambda ()
  94      (make-listing "clrf" (file-text f) (access-text a 'a)))
  95    (lambda ()
  96      (asm-16 (bitmask "0110 101a ffff ffff" (access a) (file f))))))
  97
  98 (define (comf f #!optional (d 'f) (a 'a))
  99   (make-instruction
 100    1
 101    (lambda ()
 102      (make-listing "comf" (file-text f) (dest-text d 'f) (access-text a 'a)))
 103    (lambda ()
 104      (asm-16 (bitmask "0001 11da ffff ffff" (dest d) (access a) (file f))))))
 105
 106 (define (cpfseq f #!optional (a 'a))
 107   (make-instruction
 108    -2
 109    (lambda ()
 110      (make-listing "cpfseq" (file-text f) (access-text a 'a)))
 111    (lambda ()
 112      (asm-16 (bitmask "0110 001a ffff ffff" (access a) (file f))))))
 113
 114 (define (cpfsgt f #!optional (a 'a))
 115   (make-instruction
 116    -2
 117    (lambda ()
 118      (make-listing "cpfsgt" (file-text f) (access-text a 'a)))
 119    (lambda ()
 120      (asm-16 (bitmask "0110 010a ffff ffff" (access a) (file f))))))
 121
 122 (define (cpfslt f #!optional (a 'a))
 123   (make-instruction
 124    -2
 125    (lambda ()
 126      (make-listing "cpfslt" (file-text f) (access-text a 'a)))
 127    (lambda ()
 128      (asm-16 (bitmask "0110 000a ffff ffff" (access a) (file f))))))
 129
 130 (define (decf f #!optional (d 'f) (a 'a))
 131   (make-instruction
 132    1
 133    (lambda ()
 134      (make-listing "decf" (file-text f) (dest-text d 'f) (access-text a 'a)))
 135    (lambda ()
 136      (asm-16 (bitmask "0000 01da ffff ffff" (dest d) (access a) (file f))))))
 137
 138 (define (decfsz f #!optional (d 'f) (a 'a))
 139   (make-instruction
 140    -2
 141    (lambda ()
 142      (make-listing "decfsz" (file-text f) (dest-text d 'f) (access-text a 'a)))
 143    (lambda ()
 144      (asm-16 (bitmask "0010 11da ffff ffff" (dest d) (access a) (file f))))))
 145
 146 (define (dcfsnz f #!optional (d 'f) (a 'a))
 147   (make-instruction
 148    -2
 149    (lambda ()
 150      (make-listing "dcfsnz" (file-text f) (dest-text d 'f) (access-text a 'a)))
 151    (lambda ()
 152      (asm-16 (bitmask "0100 11da ffff ffff" (dest d) (access a) (file f))))))
 153
 154 (define (incf f #!optional (d 'f) (a 'a))
 155   (make-instruction
 156    1
 157    (lambda ()
 158      (make-listing "incf" (file-text f) (dest-text d 'f) (access-text a 'a)))
 159    (lambda ()
 160      (asm-16 (bitmask "0010 10da ffff ffff" (dest d) (access a) (file f))))))
 161
 162 (define (incfsz f #!optional (d 'f) (a 'a))
 163   (make-instruction
 164    -2
 165    (lambda ()
 166      (make-listing "incfsz" (file-text f) (dest-text d 'f) (access-text a 'a)))
 167    (lambda ()
 168      (asm-16 (bitmask "0011 11da ffff ffff" (dest d) (access a) (file f))))))
 169
 170 (define (infsnz f #!optional (d 'f) (a 'a))
 171   (make-instruction
 172    -2
 173    (lambda ()
 174      (make-listing "infsnz" (file-text f) (dest-text d 'f) (access-text a 'a)))
 175    (lambda ()
 176      (asm-16 (bitmask "0100 10da ffff ffff" (dest d) (access a) (file f))))))
 177
 178 (define (iorwf f #!optional (d 'f) (a 'a))
 179   (make-instruction
 180    1
 181    (lambda ()
 182      (make-listing "iorwf" (file-text f) (dest-text d 'f) (access-text a 'a)))
 183    (lambda ()
 184      (asm-16 (bitmask "0001 00da ffff ffff" (dest d) (access a) (file f))))))
 185
 186 (define (movf f #!optional (d 'f) (a 'a))
 187   (make-instruction
 188    1
 189    (lambda ()
 190      (make-listing "movf" (file-text f) (dest-text d 'f) (access-text a 'a)))
 191    (lambda ()
 192      (asm-16 (bitmask "0101 00da ffff ffff" (dest d) (access a) (file f))))))
 193
 194 (define (movff fs fd)
 195   (make-instruction
 196    2
 197    (lambda ()
 198      (make-listing "movff" (file-text fs) (file-text fd)))
 199    (lambda ()
 200      (asm-16 (bitmask "1100 ffff ffff ffff" (file-full fs)))
 201      (asm-16 (bitmask "1111 ffff ffff ffff" (file-full fd))))))
 202
 203 (define (movwf f #!optional (a 'a))
 204   (make-instruction
 205    1
 206    (lambda ()
 207      (make-listing "movwf" (file-text f) (access-text a 'a)))
 208    (lambda ()
 209      (asm-16 (bitmask "0110 111a ffff ffff" (access a) (file f))))))
 210
 211 (define (mulwf f #!optional (a 'a))
 212   (make-instruction
 213    1
 214    (lambda ()
 215      (make-listing "mulwf" (file-text f) (access-text a 'a)))
 216    (lambda ()
 217      (asm-16 (bitmask "0000 001a ffff ffff" (access a) (file f))))))
 218
 219 (define (negf f #!optional (a 'a))
 220   (make-instruction
 221    1
 222    (lambda ()
 223      (make-listing "negf" (file-text f) (access-text a 'a)))
 224    (lambda ()
 225      (asm-16 (bitmask "0110 110a ffff ffff" (access a) (file f))))))
 226
 227 (define (rlcf f #!optional (d 'f) (a 'a))
 228   (make-instruction
 229    1
 230    (lambda ()
 231      (make-listing "rlcf" (file-text f) (dest-text d 'f) (access-text a 'a)))
 232    (lambda ()
 233      (asm-16 (bitmask "0011 01da ffff ffff" (dest d) (access a) (file f))))))
 234
 235 (define (rlncf f #!optional (d 'f) (a 'a))
 236   (make-instruction
 237    1
 238    (lambda ()
 239      (make-listing "rlncf" (file-text f) (dest-text d 'f) (access-text a 'a)))
 240    (lambda ()
 241      (asm-16 (bitmask "0100 01da ffff ffff" (dest d) (access a) (file f))))))
 242
 243 (define (rrcf f #!optional (d 'f) (a 'a))
 244   (make-instruction
 245    1
 246    (lambda ()
 247      (make-listing "rrcf" (file-text f) (dest-text d 'f) (access-text a 'a)))
 248    (lambda ()
 249      (asm-16 (bitmask "0011 00da ffff ffff" (dest d) (access a) (file f))))))
 250
 251 (define (rrncf f #!optional (d 'f) (a 'a))
 252   (make-instruction
 253    1
 254    (lambda ()
 255      (make-listing "rrncf" (file-text f) (dest-text d 'f) (access-text a 'a)))
 256    (lambda ()
 257      (asm-16 (bitmask "0100 00da ffff ffff" (dest d) (access a) (file f))))))
 258
 259 (define (setf f #!optional (a 'a))
 260   (make-instruction
 261    1
 262    (lambda ()
 263      (make-listing "setf" (file-text f) (access-text a 'a)))
 264    (lambda ()
 265      (asm-16 (bitmask "0110 100a ffff ffff" (access a) (file f))))))
 266
 267 (define (subfwb f #!optional (d 'f) (a 'a))
 268   (make-instruction
 269    1
 270    (lambda ()
 271      (make-listing "subfwb" (file-text f) (dest-text d 'f) (access-text a 'a)))
 272    (lambda ()
 273      (asm-16 (bitmask "0101 01da ffff ffff" (dest d) (access a) (file f))))))
 274
 275 (define (subwf f #!optional (d 'f) (a 'a))
 276   (make-instruction
 277    1
 278    (lambda ()
 279      (make-listing "subwf" (file-text f) (dest-text d 'f) (access-text a 'a)))
 280    (lambda ()
 281      (asm-16 (bitmask "0101 11da ffff ffff" (dest d) (access a) (file f))))))
 282
 283 (define (subwfb f #!optional (d 'f) (a 'a))
 284   (make-instruction
 285    1
 286    (lambda ()
 287      (make-listing "subwfb" (file-text f) (dest-text d 'f) (access-text a 'a)))
 288    (lambda ()
 289      (asm-16 (bitmask "0101 10da ffff ffff" (dest d) (access a) (file f))))))
 290
 291 (define (swapf f #!optional (d 'f) (a 'a))
 292   (make-instruction
 293    1
 294    (lambda ()
 295      (make-listing "swapf" (file-text f) (dest-text d 'f) (access-text a 'a)))
 296    (lambda ()
 297      (asm-16 (bitmask "0011 10da ffff ffff" (dest d) (access a) (file f))))))
 298
 299 (define (tstfsz f #!optional (a 'a))
 300   (make-instruction
 301    -2
 302    (lambda ()
 303      (make-listing "tstfsz" (file-text f) (access-text a 'a)))
 304    (lambda ()
 305      (asm-16 (bitmask "0110 011a ffff ffff" (access a) (file f))))))
 306
 307 (define (xorwf f #!optional (d 'f) (a 'a))
 308   (make-instruction
 309    1
 310    (lambda ()
 311      (make-listing "xorwf" (file-text f) (dest-text d 'f) (access-text a 'a)))
 312    (lambda ()
 313      (asm-16 (bitmask "0001 10da ffff ffff" (dest d) (access a) (file f))))))
 314
 315 ; Bit-oriented file register operations.
 316
 317 (define (bcf f b #!optional (a 'a))
 318   (make-instruction
 319    1
 320    (lambda ()
 321      (make-listing "bcf" (file-text f) (bit-text b) (access-text a 'a)))
 322    (lambda ()
 323      (asm-16 (bitmask "1001 bbba ffff ffff" (bit b) (access a) (file f))))))
 324
 325 (define (bsf f b #!optional (a 'a))
 326   (make-instruction
 327    1
 328    (lambda ()
 329      (make-listing "bsf" (file-text f) (bit-text b) (access-text a 'a)))
 330    (lambda ()
 331      (asm-16 (bitmask "1000 bbba ffff ffff" (bit b) (access a) (file f))))))
 332
 333 (define (btfsc f b #!optional (a 'a))
 334   (make-instruction
 335    -2
 336    (lambda ()
 337      (make-listing "btfsc" (file-text f) (bit-text b) (access-text a 'a)))
 338    (lambda ()
 339      (asm-16 (bitmask "1011 bbba ffff ffff" (bit b) (access a) (file f))))))
 340
 341 (define (btfss f b #!optional (a 'a))
 342   (make-instruction
 343    -2
 344    (lambda ()
 345      (make-listing "btfss" (file-text f) (bit-text b) (access-text a 'a)))
 346    (lambda ()
 347      (asm-16 (bitmask "1010 bbba ffff ffff" (bit b) (access a) (file f))))))
 348
 349 (define (btg f b #!optional (a 'a))
 350   (make-instruction
 351    1
 352    (lambda ()
 353      (make-listing "btg" (file-text f) (bit-text b) (access-text a 'a)))
 354    (lambda ()
 355      (asm-16 (bitmask "0111 bbba ffff ffff" (bit b) (access a) (file f))))))
 356
 357 ; Control operations.
 358
 359 (define (bc l)
 360   (make-short-relative-branch-instruction
 361    "bc"
 362    l
 363    (lambda (dist-8bit)
 364      (asm-16 (bitmask "1110 0010 nnnn nnnn" dist-8bit)))))
 365
 366 (define (bn l)
 367   (make-short-relative-branch-instruction
 368    "bn"
 369    l
 370    (lambda (dist-8bit)
 371      (asm-16 (bitmask "1110 0110 nnnn nnnn" dist-8bit)))))
 372
 373 (define (bnc l)
 374   (make-short-relative-branch-instruction
 375    "bnc"
 376    l
 377    (lambda (dist-8bit)
 378      (asm-16 (bitmask "1110 0011 nnnn nnnn" dist-8bit)))))
 379
 380 (define (bnn l)
 381   (make-short-relative-branch-instruction
 382    "bnn"
 383    l
 384    (lambda (dist-8bit)
 385      (asm-16 (bitmask "1110 0111 nnnn nnnn" dist-8bit)))))
 386
 387 (define (bnov l)
 388   (make-short-relative-branch-instruction
 389    "bnov"
 390    l
 391    (lambda (dist-8bit)
 392      (asm-16 (bitmask "1110 0101 nnnn nnnn" dist-8bit)))))
 393
 394 (define (bnz l)
 395   (make-short-relative-branch-instruction
 396    "bnz"
 397    l
 398    (lambda (dist-8bit)
 399      (asm-16 (bitmask "1110 0001 nnnn nnnn" dist-8bit)))))
 400
 401 (define (bov l)
 402   (make-short-relative-branch-instruction
 403    "bov"
 404    l
 405    (lambda (dist-8bit)
 406      (asm-16 (bitmask "1110 0100 nnnn nnnn" dist-8bit)))))
 407
 408 (define (bra l)
 409   (make-long-relative-branch-instruction
 410    "bra"
 411    l
 412    (lambda (dist-11bit)
 413      (asm-16 (bitmask "1101 0nnn nnnn nnnn" dist-11bit)))))
 414
 415 (define (bz l)
 416   (make-short-relative-branch-instruction
 417    "bz"
 418    l
 419    (lambda (dist-8bit)
 420      (asm-16 (bitmask "1110 0000 nnnn nnnn" dist-8bit)))))
 421
 422 (define (call l #!optional (s 0))
 423   (make-instruction
 424    2
 425    (lambda ()
 426      (make-listing "call" (label-text l) (lit-text s)))
 427    (lambda ()
 428      (asm-at-assembly
 429       (lambda (self)
 430         4)
 431       (lambda (self)
 432         (let ((pos-div-2 (quotient (label-pos l) 2)))
 433           (asm-16 (bitmask "1110 110s kkkk kkkk" s (quotient pos-div-2 4096)))
 434           (asm-16 (bitmask "1111 kkkk kkkk kkkk" (modulo pos-div-2 4096)))))))))
 435
 436 (define (clrwdt)
 437   (make-instruction
 438    1
 439    (lambda ()
 440      (make-listing "clrwdt"))
 441    (lambda ()
 442      (asm-16 (bitmask "0000 0000 0000 0100")))))
 443
 444 (define (daw)
 445   (make-instruction
 446    1
 447    (lambda ()
 448      (make-listing "daw"))
 449    (lambda ()
 450      (asm-16 (bitmask "0000 0000 0000 0111")))))
 451
 452 (define (goto l)
 453   (make-instruction
 454    2
 455    (lambda ()
 456      (make-listing "goto" (label-text l)))
 457    (lambda ()
 458      (asm-at-assembly
 459       (lambda (self)
 460         4)
 461       (lambda (self)
 462         (let ((pos-div-2 (quotient (label-pos l) 2)))
 463           (asm-16 (bitmask "1110 1111 kkkk kkkk" (quotient pos-div-2 4096)))
 464           (asm-16 (bitmask "1111 kkkk kkkk kkkk" (modulo pos-div-2 4096)))))))))
 465
 466 (define (nop)
 467   (make-instruction
 468    1
 469    (lambda ()
 470      (make-listing "nop"))
 471    (lambda ()
 472      (asm-16 (bitmask "0000 0000 0000 0000")))))
 473
 474 (define (pop)
 475   (make-instruction
 476    1
 477    (lambda ()
 478      (make-listing "pop"))
 479    (lambda ()
 480      (asm-16 (bitmask "0000 0000 0000 0110")))))
 481
 482 (define (push)
 483   (make-instruction
 484    1
 485    (lambda ()
 486      (make-listing "push"))
 487    (lambda ()
 488      (asm-16 (bitmask "0000 0000 0000 0101")))))
 489
 490 (define (rcall l)
 491   (make-long-relative-branch-instruction
 492    "rcall"
 493    l
 494    (lambda (dist-11bit)
 495      (asm-16 (bitmask "1101 1nnn nnnn nnnn" dist-11bit)))))
 496
 497 (define (reset)
 498   (make-instruction
 499    1
 500    (lambda ()
 501      (make-listing "reset"))
 502    (lambda ()
 503      (asm-16 (bitmask "0000 0000 1111 1111")))))
 504
 505 (define (retfie #!optional (s 0))
 506   (make-instruction
 507    2
 508    (lambda ()
 509      (make-listing "retfie" (lit-text s)))
 510    (lambda ()
 511      (asm-16 (bitmask "0000 0000 0001 000s" s)))))
 512
 513 (define (return #!optional (s 0))
 514   (make-instruction
 515    2
 516    (lambda ()
 517      (make-listing "return" (lit-text s)))
 518    (lambda ()
 519      (asm-16 (bitmask "0000 0000 0001 001s" s)))))
 520
 521 (define (sleep)
 522   (make-instruction
 523    1
 524    (lambda ()
 525      (make-listing "sleep"))
 526    (lambda ()
 527      (asm-16 (bitmask "0000 0000 0000 0011")))))
 528
 529 (define (make-short-relative-branch-instruction mnemonic l generate)
 530   (make-instruction
 531    -1
 532    (lambda ()
 533      (make-listing mnemonic (label-text l)))
 534    (lambda ()
 535      (asm-at-assembly
 536       (lambda (self)
 537         2)
 538       (lambda (self)
 539         (let ((dist (- (label-pos l) (+ self 2))))
 540           (if (and (>= dist -256)
 541                    (<= dist 255)
 542                    (even? dist))
 543               (generate (modulo (quotient dist 2) 256))
 544               (error "branch target is too far or improperly aligned" l dist))))))))
 545
 546 (define (make-long-relative-branch-instruction mnemonic l generate)
 547   (make-instruction
 548    -1
 549    (lambda ()
 550      (make-listing mnemonic (label-text l)))
 551    (lambda ()
 552      (asm-at-assembly
 553       (lambda (self)
 554         2)
 555       (lambda (self)
 556         (let ((dist (- (label-pos l) (+ self 2))))
 557           (if (and (>= dist -2048)
 558                    (<= dist 2047)
 559                    (even? dist))
 560               (generate (modulo (quotient dist 2) 2048))
 561               (error "branch target is too far or improperly aligned" l dist))))))))
 562
 563 ; Literal operations.
 564
 565 (define (addlw k)
 566   (make-instruction
 567    1
 568    (lambda ()
 569      (make-listing "addlw" (lit-text k)))
 570    (lambda ()
 571      (asm-16 (bitmask "0000 1111 kkkk kkkk" (lit k))))))
 572
 573 (define (andlw k)
 574   (make-instruction
 575    1
 576    (lambda ()
 577      (make-listing "andlw" (lit-text k)))
 578    (lambda ()
 579      (asm-16 (bitmask "0000 1011 kkkk kkkk" (lit k))))))
 580
 581 (define (iorlw k)
 582   (make-instruction
 583    1
 584    (lambda ()
 585      (make-listing "iorlw" (lit-text k)))
 586    (lambda ()
 587      (asm-16 (bitmask "0000 1001 kkkk kkkk" (lit k))))))
 588
 589 (define (lfsr f k)
 590   (make-instruction
 591    2
 592    (lambda ()
 593      (make-listing "lfsr" (file-text f) (lit-text k)))
 594    (lambda ()
 595      (asm-16 (bitmask "1110 1110 00ff kkkk" (file f) (quotient (lit k) 256)))
 596      (asm-16 (bitmask "1111 0000 kkkk kkkk" (modulo (lit k) 256))))))
 597
 598 (define (movlb k)
 599   (make-instruction
 600    1
 601    (lambda ()
 602      (make-listing "movlb" (lit-text k)))
 603    (lambda ()
 604      (asm-16 (bitmask "0000 0001 0000 kkkk" (lit k))))))
 605
 606 (define (movlw k)
 607   (make-instruction
 608    1
 609    (lambda ()
 610      (make-listing "movlw" (lit-text k)))
 611    (lambda ()
 612      (asm-16 (bitmask "0000 1110 kkkk kkkk" (lit k))))))
 613
 614 (define (mullw k)
 615   (make-instruction
 616    1
 617    (lambda ()
 618      (make-listing "mullw" (lit-text k)))
 619    (lambda ()
 620      (asm-16 (bitmask "0000 1101 kkkk kkkk" (lit k))))))
 621
 622 (define (retlw k)
 623   (make-instruction
 624    2
 625    (lambda ()
 626      (make-listing "retlw" (lit-text k)))
 627    (lambda ()
 628      (asm-16 (bitmask "0000 1100 kkkk kkkk" (lit k))))))
 629
 630 (define (sublw k)
 631   (make-instruction
 632    1
 633    (lambda ()
 634      (make-listing "sublw" (lit-text k)))
 635    (lambda ()
 636      (asm-16 (bitmask "0000 1000 kkkk kkkk" (lit k))))))
 637
 638 (define (xorlw k)
 639   (make-instruction
 640    1
 641    (lambda ()
 642      (make-listing "xorlw" (lit-text k)))
 643    (lambda ()
 644      (asm-16 (bitmask "0000 1010 kkkk kkkk" (lit k))))))
 645
 646 ; Data memory program memory operations.
 647
 648 (define (tblrd*)
 649   (make-instruction
 650    2
 651    (lambda ()
 652      (make-listing "tblrd*"))
 653    (lambda ()
 654      (asm-16 (bitmask "0000 0000 0000 1000")))))
 655
 656 (define (tblrd*+)
 657   (make-instruction
 658    2
 659    (lambda ()
 660      (make-listing "tblrd*+"))
 661    (lambda ()
 662      (asm-16 (bitmask "0000 0000 0000 1001")))))
 663
 664 (define (tblrd*-)
 665   (make-instruction
 666    2
 667    (lambda ()
 668      (make-listing "tblrd*-"))
 669    (lambda ()
 670      (asm-16 (bitmask "0000 0000 0000 1010")))))
 671
 672 (define (tblrd+*)
 673   (make-instruction
 674    2
 675    (lambda ()
 676      (make-listing "tblrd+*"))
 677    (lambda ()
 678      (asm-16 (bitmask "0000 0000 0000 1011")))))
 679
 680 (define (tblwt*)
 681   (make-instruction
 682    2
 683    (lambda ()
 684      (make-listing "tblwt*"))
 685    (lambda ()
 686      (asm-16 (bitmask "0000 0000 0000 1100")))))
 687
 688 (define (tblwt*+)
 689   (make-instruction
 690    2
 691    (lambda ()
 692      (make-listing "tblwt*+"))
 693    (lambda ()
 694      (asm-16 (bitmask "0000 0000 0000 1101")))))
 695
 696 (define (tblwt*-)
 697   (make-instruction
 698    2
 699    (lambda ()
 700      (make-listing "tblwt*-"))
 701    (lambda ()
 702      (asm-16 (bitmask "0000 0000 0000 1110")))))
 703
 704 (define (tblwt+*)
 705   (make-instruction
 706    2
 707    (lambda ()
 708      (make-listing "tblwt+*"))
 709    (lambda ()
 710      (asm-16 (bitmask "0000 0000 0000 1111")))))
 711
 712 ;------------------------------------------------------------------------------
 713
 714
 715
 716 #|
 717
 718 (define (andlw k)
 719   (make-instruction
 720    1
 721    (lambda ()
 722      (make-listing "andlw" (lit-text k)))
 723    (lambda ()
 724      (asm-16 (+ #b0000101100000000 (lit8 k))))))
 725
 726 (define (iorlw k)
 727   (make-instruction
 728    1
 729    (lambda ()
 730      (make-listing "iorlw" (lit-text k)))
 731    (lambda ()
 732      (asm-16 (+ #b0000100100000000 (lit8 k))))))
 733
 734 (define (lfsr f k)
 735   (make-instruction
 736    2
 737    (lambda ()
 738      (make-listing "lfsr" (lit-text f) "," (lit-text k)))
 739    (lambda ()
 740      (asm-16 (+ #b1110111000000000 (* (lit2 f) 16) (quotient (lit12 k) 256)))
 741      (asm-16 (+ #b1111000000000000 (modulo (lit12 k) 256))))))
 742
 743 (define (movlb k)
 744   (make-instruction
 745    1
 746    (lambda ()
 747      (make-listing "movlb" (lit-text k)))
 748    (lambda ()
 749      (asm-16 (+ #b0000000100000000 (lit4 k))))))
 750
 751 (define (movlw k)
 752   (make-instruction
 753    1
 754    (lambda ()
 755      (make-listing "movlw" (lit-text k)))
 756    (lambda ()
 757      (asm-16 (+ #b0000111000000000 (lit8 k))))))
 758
 759 (define (mullw k)
 760   (make-instruction
 761    1
 762    (lambda ()
 763      (make-listing "mullw" (lit-text k)))
 764    (lambda ()
 765      (asm-16 (+ #b0000110100000000 (lit8 k))))))
 766
 767 (define (retlw k)
 768   (make-instruction
 769    2
 770    (lambda ()
 771      (make-listing "retlw" (lit-text k)))
 772    (lambda ()
 773      (asm-16 (+ #b0000110000000000 (lit8 k))))))
 774
 775 (define (sublw k)
 776   (make-instruction
 777    1
 778    (lambda ()
 779      (make-listing "sublw" (lit-text k)))
 780    (lambda ()
 781      (asm-16 (+ #b0000100000000000 (lit8 k))))))
 782
 783 (define (xorlw k)
 784   (make-instruction
 785    1
 786    (lambda ()
 787      (make-listing "xorlw" (lit-text k)))
 788    (lambda ()
 789      (asm-16 (+ #b0000101000000000 (lit8 k))))))
 790
 791 (define (tblrd*)
 792   (make-instruction
 793    2
 794    (lambda ()
 795      (make-listing "tblrd*"))
 796    (lambda ()
 797      (asm-16 #b0000000000001000))))
 798
 799 (define (tblrd*+)
 800   (make-instruction
 801    2
 802    (lambda ()
 803      (make-listing "tblrd*+"))
 804    (lambda ()
 805      (asm-16 #b0000000000001001))))
 806
 807 (define (tblrd*-)
 808   (make-instruction
 809    2
 810    (lambda ()
 811      (make-listing "tblrd*-"))
 812    (lambda ()
 813      (asm-16 #b0000000000001010))))
 814
 815 (define (tblrd+*)
 816   (make-instruction
 817    2
 818    (lambda ()
 819      (make-listing "tblrd+*"))
 820    (lambda ()
 821      (asm-16 #b0000000000001011))))
 822
 823 (define (tblwt*)
 824   (make-instruction
 825    2
 826    (lambda ()
 827      (make-listing "tblwt*"))
 828    (lambda ()
 829      (asm-16 #b0000000000001100))))
 830
 831 (define (tblwt*+)
 832   (make-instruction
 833    2
 834    (lambda ()
 835      (make-listing "tblwt*+"))
 836    (lambda ()
 837      (asm-16 #b0000000000001101))))
 838
 839 (define (tblwt*-)
 840   (make-instruction
 841    2
 842    (lambda ()
 843      (make-listing "tblwt*-"))
 844    (lambda ()
 845      (asm-16 #b0000000000001110))))
 846
 847 (define (tblwt+*)
 848   (make-instruction
 849    2
 850    (lambda ()
 851      (make-listing "tblwt+*"))
 852    (lambda ()
 853      (asm-16 #b0000000000001111))))
 854
 855 (define (lit2 n)
 856   (if (and (>= n 0) (<= n 3))
 857       n
 858       (error "2 bit literal expected but got" n)))
 859
 860 (define (lit8 n)
 861   (if (and (>= n 0) (<= n 255))
 862       n
 863       (error "8 bit literal expected but got" n)))
 864
 865 (define (lit12 n)
 866   (if (and (>= n 0) (<= n 2047))
 867       n
 868       (error "12 bit literal expected but got" n)))
 869
 870 |#
 871
 872 (define (make-instruction cycles listing-thunk code-thunk)
 873   (code-thunk)
 874   (listing-thunk))
 875
 876 (define (make-listing mnemonic . operands)
 877
 878   (define (operand-list operands)
 879     (if (null? operands)
 880         ""
 881         (let ((rest (operand-list (cdr operands))))
 882           (string-append (car operands)
 883                          (if (string=? rest "")
 884                              ""
 885                              (string-append ", " rest))))))
 886
 887   (asm-listing
 888    (list "    "
 889          mnemonic
 890          (make-string (- 8 (string-length mnemonic)) #\space)
 891          (operand-list operands))))
 892
 893 (define (dest d)
 894   (cond ((eq? d 'w) 0)
 895         ((eq? d 'f) 1)
 896         (else       (error "destination bit must be w or f"))))
 897
 898 (define (dest-text d default)
 899   (cond ((eq? d default) "")
 900         ((eq? d 'w) "w")
 901         ((eq? d 'f) "f")
 902         (else       (error "destination bit must be w or f"))))
 903
 904 (define (access a)
 905   (cond ((eq? a 'a) 0)
 906         ((eq? a 'b) 1)
 907         (else       (error "access bit must be a or b"))))
 908
 909 (define (access-text a default)
 910   (cond ((eq? a default) "")
 911         ((eq? a 'a) "a")
 912         ((eq? a 'b) "b")
 913         (else       (error "access bit must be a or b"))))
 914
 915 (define (lit k)
 916   k)
 917
 918 (define (lit-text k)
 919
 920   (define (text k)
 921     (if (<= k 10)
 922         (number->string k)
 923         (string-append "0x" (number->string k 16))))
 924
 925   (if (< k 0)
 926       (string-append "-" (text (abs k)))
 927       (text k)))
 928
 929 (define (bit b)
 930   b)
 931
 932 (define (bit-text b)
 933   (lit-text b))
 934
 935 (define (file f)
 936   (if (or (>= f #xf80) (< #x080))
 937       (modulo f #x100)
 938       (error "illegal file register")))
 939
 940 (define (file-full f)
 941   f)
 942
 943 (define (file-text f)
 944   (let ((x (assv f file-reg-names)))
 945     (if x
 946         (symbol->string (cdr x))
 947         (lit-text f))))
 948
 949 (define (label-text label)
 950   (if (number? label)
 951       (string-append "0x" (number->string label 16))
 952       (symbol->string (asm-label-id label))))
 953
 954 (define (label-pos label)
 955   (if (number? label)
 956       label
 957       (asm-label-pos label)))
 958
 959 ;------------------------------------------------------------------------------
 960
 961 (define TOSU     #xfff)
 962 (define TOSH     #xffe)
 963 (define TOSL     #xffd)
 964 (define STKPTR   #xffc)
 965 (define PCLATU   #xffb)
 966 (define PCLATH   #xffa)
 967 (define PCL      #xff9)
 968 (define TBLPTRU  #xff8)
 969 (define TBLPTRH  #xff7)
 970 (define TBLPTRL  #xff6)
 971 (define TABLAT   #xff5)
 972 (define PRODH    #xff4)
 973 (define PRODL    #xff3)
 974 (define INDF0    #xfef)
 975 (define POSTINC0 #xfee)
 976 (define POSTDEC0 #xfed)
 977 (define PREINC0  #xfec)
 978 (define PLUSW0   #xfeb)
 979 (define FSR0H    #xfea)
 980 (define FSR0L    #xfe9)
 981 (define WREG     #xfe8)
 982 (define INDF1    #xfe7)
 983 (define POSTINC1 #xfe6)
 984 (define POSTDEC1 #xfe5)
 985 (define PREINC1  #xfe4)
 986 (define PLUSW1   #xfe3)
 987 (define FSR1H    #xfe2)
 988 (define FSR1L    #xfe1)
 989 (define BSR      #xfe0)
 990 (define INDF2    #xfdf)
 991 (define POSTINC2 #xfde)
 992 (define POSTDEC2 #xfdd)
 993 (define PREINC2  #xfdc)
 994 (define PLUSW2   #xfdb)
 995 (define FSR2H    #xfda)
 996 (define FSR2L    #xfd9)
 997 (define STATUS   #xfd8)
 998 (define TMR1H    #xfcf)
 999 (define TMR1L    #xfce)
1000 (define PORTE    #xf84)
1001 (define PORTD    #xf83)
1002 (define PORTC    #xf82)
1003 (define PORTB    #xf81)
1004 (define PORTA    #xf80)
1005
1006 (define file-reg-names '(
1007   (#xfff . TOSU)
1008   (#xffe . TOSH)
1009   (#xffd . TOSL)
1010   (#xffc . STKPTR)
1011   (#xffb . PCLATU)
1012   (#xffa . PCLATH)
1013   (#xff9 . PCL)
1014   (#xff8 . TBLPTRU)
1015   (#xff7 . TBLPTRH)
1016   (#xff6 . TBLPTRL)
1017   (#xff5 . TABLAT)
1018   (#xff4 . PRODH)
1019   (#xff3 . PRODL)
1020   (#xfef . INDF0)
1021   (#xfee . POSTINC0)
1022   (#xfed . POSTDEC0)
1023   (#xfec . PREINC0)
1024   (#xfeb . PLUSW0)
1025   (#xfea . FSR0H)
1026   (#xfe9 . FSR0L)
1027   (#xfe8 . WREG)
1028   (#xfe7 . INDF1)
1029   (#xfe6 . POSTINC1)
1030   (#xfe5 . POSTDEC1)
1031   (#xfe4 . PREINC1)
1032   (#xfe3 . PLUSW1)
1033   (#xfe2 . FSR1H)
1034   (#xfe1 . FSR1L)
1035   (#xfe0 . BSR)
1036   (#xfdf . INDF2)
1037   (#xfde . POSTINC2)
1038   (#xfdd . POSTDEC2)
1039   (#xfdc . PREINC2)
1040   (#xfdb . PLUSW2)
1041   (#xfda . FSR2H)
1042   (#xfd9 . FSR2L)
1043   (#xfd8 . STATUS)
1044   (#xfd7 . TMR0H)
1045   (#xfd6 . TMR0L)
1046   (#xfd5 . T0CON)
1047   (#xfd3 . OSCCON)
1048   (#xfcf . TMR1H)
1049   (#xfce . TMR1L)
1050   (#xfcd . T1CON)
1051   (#xfc1 . ADCON1)
1052   (#xfdb . PLUSW2)
1053   (#xfa1 . PIR2)
1054   (#xfa0 . PIE2)
1055   (#xf9e . PIR1)
1056   (#xf9d . PIE1)
1057   (#xf93 . TRISB)
1058   (#xf92 . TRISA)
1059   (#xf8a . LATB)
1060   (#xf89 . LATA)
1061   (#xf84 . PORTE)
1062   (#xf83 . PORTD)
1063   (#xf82 . PORTC)
1064   (#xf81 . PORTB)
1065   (#xf80 . PORTA)
1066 ))
1067
1068 (define C  0)
1069 (define DC 1)
1070 (define Z  2)
1071 (define OV 3)
1072 (define N  4)
1073
1074 ;------------------------------------------------------------------------------
1075
1076 (define (label-offset-reference label offset)
1077   (asm-at-assembly
1078     (lambda (self)
1079       2)
1080     (lambda (self)
1081       (asm-16 (+ (asm-label-pos label) offset)))))
1082
1083 (define (label-instr label opcode)
1084   (asm-at-assembly
1085     (lambda (self)
1086       2)
1087     (lambda (self)
1088       (let ((pos (asm-label-pos label)))
1089         (asm-8 (+ (quotient pos 256) opcode))
1090         (asm-8 (modulo pos 256))))))
1091
1092 ;------------------------------------------------------------------------------
1093
1094 (define irda_send_newline               #x0078)
1095 (define irda_send                       #x007E)
1096 (define irda_recv_with_1_sec_timeout    #x00A2)
1097 (define irda_recv                       #x00A4)
1098 (define sec_sleep                       #x00B0)
1099 (define msec_sleep                      #x00B6)
1100 (define delay_7                         #x00D4)
1101 (define led_set                         #x00D6)
1102 (define bit_set                         #x00EC)
1103 (define FLASH_execute_erase             #x0106)
1104 (define FLASH_execute_write             #x0108)
1105 (define parse_hex_byte                  #x0184)
1106 (define parse_hex_digit                 #x0194)
1107 (define irda_send_hex                   #x01AE)
1108 (define irda_send_nibble                #x01B6)
1109
1110 ;------------------------------------------------------------------------------