pic18.scm

   1 ;;; File: "pic18.scm"
   2
   3 (load "asm")
   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 (bra-or-goto l)
 416   (make-long-relative-or-absolute-branch-instruction
 417    "bra"
 418    "goto"
 419    l
 420    (lambda (dist-11bit)
 421      (asm-16 (bitmask "1101 0nnn nnnn nnnn" dist-11bit)))
 422    (lambda (pos-20bit)
 423      (asm-16 (bitmask "1110 1111 nnnn nnnn" (modulo pos-20bit (expt 2 8))))
 424      (asm-16 (bitmask "1111 nnnn nnnn nnnn" (quotient pos-20bit (expt 2 8)))))))
 425
 426 (define (bz l)
 427   (make-short-relative-branch-instruction
 428    "bz"
 429    l
 430    (lambda (dist-8bit)
 431      (asm-16 (bitmask "1110 0000 nnnn nnnn" dist-8bit)))))
 432
 433 (define (call l #!optional (s 0))
 434   (make-instruction
 435    2
 436    (lambda ()
 437      (make-listing "call" (label-text l) (lit-text s)))
 438    (lambda ()
 439      (asm-at-assembly
 440       (lambda (self)
 441         4)
 442       (lambda (self)
 443         (let ((pos-div-2 (quotient (label-pos l) 2)))
 444           (asm-16 (bitmask "1110 110s kkkk kkkk" s (quotient pos-div-2 4096)))
 445           (asm-16 (bitmask "1111 kkkk kkkk kkkk" (modulo pos-div-2 4096)))))))))
 446
 447 (define (clrwdt)
 448   (make-instruction
 449    1
 450    (lambda ()
 451      (make-listing "clrwdt"))
 452    (lambda ()
 453      (asm-16 (bitmask "0000 0000 0000 0100")))))
 454
 455 (define (daw)
 456   (make-instruction
 457    1
 458    (lambda ()
 459      (make-listing "daw"))
 460    (lambda ()
 461      (asm-16 (bitmask "0000 0000 0000 0111")))))
 462
 463 (define (goto l)
 464   (make-instruction
 465    2
 466    (lambda ()
 467      (make-listing "goto" (label-text l)))
 468    (lambda ()
 469      (asm-at-assembly
 470       (lambda (self)
 471         4)
 472       (lambda (self)
 473         (let ((pos-div-2 (quotient (label-pos l) 2)))
 474           (asm-16 (bitmask "1110 1111 kkkk kkkk" (quotient pos-div-2 4096)))
 475           (asm-16 (bitmask "1111 kkkk kkkk kkkk" (modulo pos-div-2 4096)))))))))
 476
 477 (define (nop)
 478   (make-instruction
 479    1
 480    (lambda ()
 481      (make-listing "nop"))
 482    (lambda ()
 483      (asm-16 (bitmask "0000 0000 0000 0000")))))
 484
 485 (define (pop)
 486   (make-instruction
 487    1
 488    (lambda ()
 489      (make-listing "pop"))
 490    (lambda ()
 491      (asm-16 (bitmask "0000 0000 0000 0110")))))
 492
 493 (define (push)
 494   (make-instruction
 495    1
 496    (lambda ()
 497      (make-listing "push"))
 498    (lambda ()
 499      (asm-16 (bitmask "0000 0000 0000 0101")))))
 500
 501 (define (rcall l)
 502   (make-long-relative-branch-instruction
 503    "rcall"
 504    l
 505    (lambda (dist-11bit)
 506      (asm-16 (bitmask "1101 1nnn nnnn nnnn" dist-11bit)))))
 507
 508 (define (rcall-or-call l)
 509   (make-long-relative-or-absolute-branch-instruction
 510    "rcall"
 511    "call"
 512    l
 513    (lambda (dist-11bit)
 514      (asm-16 (bitmask "1101 1nnn nnnn nnnn" dist-11bit)))
 515    (lambda (pos-20bit)
 516      (asm-16 (bitmask "1110 1100 nnnn nnnn" (modulo pos-20bit (expt 2 8))))
 517      (asm-16 (bitmask "1111 nnnn nnnn nnnn" (quotient pos-20bit (expt 2 8)))))))
 518
 519 (define (reset)
 520   (make-instruction
 521    1
 522    (lambda ()
 523      (make-listing "reset"))
 524    (lambda ()
 525      (asm-16 (bitmask "0000 0000 1111 1111")))))
 526
 527 (define (retfie #!optional (s 0))
 528   (make-instruction
 529    2
 530    (lambda ()
 531      (make-listing "retfie" (lit-text s)))
 532    (lambda ()
 533      (asm-16 (bitmask "0000 0000 0001 000s" s)))))
 534
 535 (define (return #!optional (s 0))
 536   (make-instruction
 537    2
 538    (lambda ()
 539      (make-listing "return" (lit-text s)))
 540    (lambda ()
 541      (asm-16 (bitmask "0000 0000 0001 001s" s)))))
 542
 543 (define (sleep)
 544   (make-instruction
 545    1
 546    (lambda ()
 547      (make-listing "sleep"))
 548    (lambda ()
 549      (asm-16 (bitmask "0000 0000 0000 0011")))))
 550
 551 (define (make-short-relative-branch-instruction mnemonic l generate)
 552   (make-instruction
 553    -1
 554    (lambda ()
 555      (make-listing mnemonic (label-text l)))
 556    (lambda ()
 557      (asm-at-assembly
 558       (lambda (self)
 559         2)
 560       (lambda (self)
 561         (let ((dist (- (label-pos l) (+ self 2))))
 562           (if (and (>= dist -256)
 563                    (<= dist 255)
 564                    (even? dist))
 565               (generate (modulo (quotient dist 2) 256))
 566               (error "short relative branch target is too far or improperly aligned" l dist))))))))
 567
 568 (define (make-long-relative-branch-instruction mnemonic l generate)
 569   (make-instruction
 570    -1
 571    (lambda ()
 572      (make-listing mnemonic (label-text l)))
 573    (lambda ()
 574      (asm-at-assembly
 575       (lambda (self)
 576         2)
 577       (lambda (self)
 578         (let ((dist (- (label-pos l) (+ self 2))))
 579           (if (and (>= dist -2048)
 580                    (<= dist 2047)
 581                    (even? dist))
 582               (generate (modulo (quotient dist 2) 2048))
 583               (error "long relative branch target is too far or improperly aligned" l dist))))))))
 584
 585 (define (make-long-relative-or-absolute-branch-instruction mnemonic1 mnemonic2 l generate1 generate2)
 586   (make-instruction
 587    -1
 588    (lambda ()
 589      (make-listing mnemonic1 (label-text l))) ;; TODO should show mnemonic1 when it's used, or mnemonic2
 590    (lambda ()
 591      (asm-at-assembly ;; TODO seems to mix up generation of call vs rcall, see the rom_get example FOO
 592       (lambda (self)
 593         (let ((dist (- (label-pos l) (+ self 2))))
 594           (if (and (>= dist -2048)
 595                    (<= dist 2047)
 596                    (even? dist))
 597               2
 598               #f)))
 599       (lambda (self)
 600         (let ((dist (- (label-pos l) (+ self 2))))
 601           (generate1 (modulo (quotient dist 2) 2048))))
 602       (lambda (self)
 603         4)
 604       (lambda (self)
 605         (let ((pos (label-pos l)))
 606           (if (and (< pos (expt 2 21))
 607                    (even? pos))
 608               (generate2 (quotient pos 2))
 609               (error "goto branch target is too far or unaligned" l pos))))))))
 610
 611 ; Literal operations.
 612
 613 (define (addlw k)
 614   (make-instruction
 615    1
 616    (lambda ()
 617      (make-listing "addlw" (lit-text k)))
 618    (lambda ()
 619      (asm-16 (bitmask "0000 1111 kkkk kkkk" (lit k))))))
 620
 621 (define (andlw k)
 622   (make-instruction
 623    1
 624    (lambda ()
 625      (make-listing "andlw" (lit-text k)))
 626    (lambda ()
 627      (asm-16 (bitmask "0000 1011 kkkk kkkk" (lit k))))))
 628
 629 (define (iorlw k)
 630   (make-instruction
 631    1
 632    (lambda ()
 633      (make-listing "iorlw" (lit-text k)))
 634    (lambda ()
 635      (asm-16 (bitmask "0000 1001 kkkk kkkk" (lit k))))))
 636
 637 (define (lfsr f k)
 638   (make-instruction
 639    2
 640    (lambda ()
 641      (make-listing "lfsr" (file-text f) (lit-text k)))
 642    (lambda ()
 643      (asm-16 (bitmask "1110 1110 00ff kkkk" (file f) (quotient (lit k) 256)))
 644      (asm-16 (bitmask "1111 0000 kkkk kkkk" (modulo (lit k) 256))))))
 645
 646 (define (movlb k)
 647   (make-instruction
 648    1
 649    (lambda ()
 650      (make-listing "movlb" (lit-text k)))
 651    (lambda ()
 652      (asm-16 (bitmask "0000 0001 0000 kkkk" (lit k))))))
 653
 654 (define (movlw k)
 655   (make-instruction
 656    1
 657    (lambda ()
 658      (make-listing "movlw" (lit-text k)))
 659    (lambda ()
 660      (asm-16 (bitmask "0000 1110 kkkk kkkk" (lit k))))))
 661
 662 (define (mullw k)
 663   (make-instruction
 664    1
 665    (lambda ()
 666      (make-listing "mullw" (lit-text k)))
 667    (lambda ()
 668      (asm-16 (bitmask "0000 1101 kkkk kkkk" (lit k))))))
 669
 670 (define (retlw k)
 671   (make-instruction
 672    2
 673    (lambda ()
 674      (make-listing "retlw" (lit-text k)))
 675    (lambda ()
 676      (asm-16 (bitmask "0000 1100 kkkk kkkk" (lit k))))))
 677
 678 (define (sublw k)
 679   (make-instruction
 680    1
 681    (lambda ()
 682      (make-listing "sublw" (lit-text k)))
 683    (lambda ()
 684      (asm-16 (bitmask "0000 1000 kkkk kkkk" (lit k))))))
 685
 686 (define (xorlw k)
 687   (make-instruction
 688    1
 689    (lambda ()
 690      (make-listing "xorlw" (lit-text k)))
 691    (lambda ()
 692      (asm-16 (bitmask "0000 1010 kkkk kkkk" (lit k))))))
 693
 694 ; Data memory program memory operations.
 695
 696 (define (tblrd*)
 697   (make-instruction
 698    2
 699    (lambda ()
 700      (make-listing "tblrd*"))
 701    (lambda ()
 702      (asm-16 (bitmask "0000 0000 0000 1000")))))
 703
 704 (define (tblrd*+)
 705   (make-instruction
 706    2
 707    (lambda ()
 708      (make-listing "tblrd*+"))
 709    (lambda ()
 710      (asm-16 (bitmask "0000 0000 0000 1001")))))
 711
 712 (define (tblrd*-)
 713   (make-instruction
 714    2
 715    (lambda ()
 716      (make-listing "tblrd*-"))
 717    (lambda ()
 718      (asm-16 (bitmask "0000 0000 0000 1010")))))
 719
 720 (define (tblrd+*)
 721   (make-instruction
 722    2
 723    (lambda ()
 724      (make-listing "tblrd+*"))
 725    (lambda ()
 726      (asm-16 (bitmask "0000 0000 0000 1011")))))
 727
 728 (define (tblwt*)
 729   (make-instruction
 730    2
 731    (lambda ()
 732      (make-listing "tblwt*"))
 733    (lambda ()
 734      (asm-16 (bitmask "0000 0000 0000 1100")))))
 735
 736 (define (tblwt*+)
 737   (make-instruction
 738    2
 739    (lambda ()
 740      (make-listing "tblwt*+"))
 741    (lambda ()
 742      (asm-16 (bitmask "0000 0000 0000 1101")))))
 743
 744 (define (tblwt*-)
 745   (make-instruction
 746    2
 747    (lambda ()
 748      (make-listing "tblwt*-"))
 749    (lambda ()
 750      (asm-16 (bitmask "0000 0000 0000 1110")))))
 751
 752 (define (tblwt+*)
 753   (make-instruction
 754    2
 755    (lambda ()
 756      (make-listing "tblwt+*"))
 757    (lambda ()
 758      (asm-16 (bitmask "0000 0000 0000 1111")))))
 759
 760 ;------------------------------------------------------------------------------
 761
 762
 763
 764 #|
 765
 766 (define (andlw k)
 767   (make-instruction
 768    1
 769    (lambda ()
 770      (make-listing "andlw" (lit-text k)))
 771    (lambda ()
 772      (asm-16 (+ #b0000101100000000 (lit8 k))))))
 773
 774 (define (iorlw k)
 775   (make-instruction
 776    1
 777    (lambda ()
 778      (make-listing "iorlw" (lit-text k)))
 779    (lambda ()
 780      (asm-16 (+ #b0000100100000000 (lit8 k))))))
 781
 782 (define (lfsr f k)
 783   (make-instruction
 784    2
 785    (lambda ()
 786      (make-listing "lfsr" (lit-text f) "," (lit-text k)))
 787    (lambda ()
 788      (asm-16 (+ #b1110111000000000 (* (lit2 f) 16) (quotient (lit12 k) 256)))
 789      (asm-16 (+ #b1111000000000000 (modulo (lit12 k) 256))))))
 790
 791 (define (movlb k)
 792   (make-instruction
 793    1
 794    (lambda ()
 795      (make-listing "movlb" (lit-text k)))
 796    (lambda ()
 797      (asm-16 (+ #b0000000100000000 (lit4 k))))))
 798
 799 (define (movlw k)
 800   (make-instruction
 801    1
 802    (lambda ()
 803      (make-listing "movlw" (lit-text k)))
 804    (lambda ()
 805      (asm-16 (+ #b0000111000000000 (lit8 k))))))
 806
 807 (define (mullw k)
 808   (make-instruction
 809    1
 810    (lambda ()
 811      (make-listing "mullw" (lit-text k)))
 812    (lambda ()
 813      (asm-16 (+ #b0000110100000000 (lit8 k))))))
 814
 815 (define (retlw k)
 816   (make-instruction
 817    2
 818    (lambda ()
 819      (make-listing "retlw" (lit-text k)))
 820    (lambda ()
 821      (asm-16 (+ #b0000110000000000 (lit8 k))))))
 822
 823 (define (sublw k)
 824   (make-instruction
 825    1
 826    (lambda ()
 827      (make-listing "sublw" (lit-text k)))
 828    (lambda ()
 829      (asm-16 (+ #b0000100000000000 (lit8 k))))))
 830
 831 (define (xorlw k)
 832   (make-instruction
 833    1
 834    (lambda ()
 835      (make-listing "xorlw" (lit-text k)))
 836    (lambda ()
 837      (asm-16 (+ #b0000101000000000 (lit8 k))))))
 838
 839 (define (tblrd*)
 840   (make-instruction
 841    2
 842    (lambda ()
 843      (make-listing "tblrd*"))
 844    (lambda ()
 845      (asm-16 #b0000000000001000))))
 846
 847 (define (tblrd*+)
 848   (make-instruction
 849    2
 850    (lambda ()
 851      (make-listing "tblrd*+"))
 852    (lambda ()
 853      (asm-16 #b0000000000001001))))
 854
 855 (define (tblrd*-)
 856   (make-instruction
 857    2
 858    (lambda ()
 859      (make-listing "tblrd*-"))
 860    (lambda ()
 861      (asm-16 #b0000000000001010))))
 862
 863 (define (tblrd+*)
 864   (make-instruction
 865    2
 866    (lambda ()
 867      (make-listing "tblrd+*"))
 868    (lambda ()
 869      (asm-16 #b0000000000001011))))
 870
 871 (define (tblwt*)
 872   (make-instruction
 873    2
 874    (lambda ()
 875      (make-listing "tblwt*"))
 876    (lambda ()
 877      (asm-16 #b0000000000001100))))
 878
 879 (define (tblwt*+)
 880   (make-instruction
 881    2
 882    (lambda ()
 883      (make-listing "tblwt*+"))
 884    (lambda ()
 885      (asm-16 #b0000000000001101))))
 886
 887 (define (tblwt*-)
 888   (make-instruction
 889    2
 890    (lambda ()
 891      (make-listing "tblwt*-"))
 892    (lambda ()
 893      (asm-16 #b0000000000001110))))
 894
 895 (define (tblwt+*)
 896   (make-instruction
 897    2
 898    (lambda ()
 899      (make-listing "tblwt+*"))
 900    (lambda ()
 901      (asm-16 #b0000000000001111))))
 902
 903 (define (lit2 n)
 904   (if (and (>= n 0) (<= n 3))
 905       n
 906       (error "2 bit literal expected but got" n)))
 907
 908 (define (lit8 n)
 909   (if (and (>= n 0) (<= n 255))
 910       n
 911       (error "8 bit literal expected but got" n)))
 912
 913 (define (lit12 n)
 914   (if (and (>= n 0) (<= n 2047))
 915       n
 916       (error "12 bit literal expected but got" n)))
 917
 918 |#
 919
 920 (define (make-instruction cycles listing-thunk code-thunk)
 921   (code-thunk)
 922   (listing-thunk))
 923
 924 (define (make-listing mnemonic . operands)
 925
 926   (define (operand-list operands)
 927     (if (null? operands)
 928         ""
 929         (let ((rest (operand-list (cdr operands))))
 930           (string-append (car operands)
 931                          (if (string=? rest "")
 932                              ""
 933                              (string-append ", " rest))))))
 934
 935   (asm-listing
 936    (list "    "
 937          mnemonic
 938          (make-string (- 8 (string-length mnemonic)) #\space)
 939          (operand-list operands))))
 940
 941 (define (dest d)
 942   (cond ((eq? d 'w) 0)
 943         ((eq? d 'f) 1)
 944         (else       (error "destination bit must be w or f"))))
 945
 946 (define (dest-text d default)
 947   (cond ((eq? d default) "")
 948         ((eq? d 'w) "w")
 949         ((eq? d 'f) "f")
 950         (else       (error "destination bit must be w or f"))))
 951
 952 (define (access a)
 953   (cond ((eq? a 'a) 0)
 954         ((eq? a 'b) 1)
 955         (else       (error "access bit must be a or b"))))
 956
 957 (define (access-text a default)
 958   (cond ((eq? a default) "")
 959         ((eq? a 'a) "a")
 960         ((eq? a 'b) "b")
 961         (else       (error "access bit must be a or b"))))
 962
 963 (define (lit k)
 964   k)
 965
 966 (define (lit-text k)
 967
 968   (define (text k)
 969     (if (<= k 10)
 970         (number->string k)
 971         (string-append "0x" (number->string k 16))))
 972
 973   (if (< k 0)
 974       (string-append "-" (text (abs k)))
 975       (text k)))
 976
 977 (define (bit b)
 978   b)
 979
 980 (define (bit-text b)
 981   (lit-text b))
 982
 983 (define (file f)
 984   (if (or (>= f #xf80) (< #x080))
 985       (modulo f #x100)
 986       (error "illegal file register")))
 987
 988 (define (file-full f)
 989   f)
 990
 991 (define (file-text f)
 992   (let ((x (assv f file-reg-names)))
 993     (if x
 994         (symbol->string (cdr x))
 995         (lit-text f))))
 996
 997 (define (label-text label)
 998   (if (number? label)
 999       (string-append "0x" (number->string label 16))
1000       (symbol->string (asm-label-id label))))
1001
1002 (define (label-pos label)
1003   (if (number? label)
1004       label
1005       (asm-label-pos label)))
1006
1007 ;------------------------------------------------------------------------------
1008
1009 (define TOSU     #xfff)
1010 (define TOSH     #xffe)
1011 (define TOSL     #xffd)
1012 (define STKPTR   #xffc)
1013 (define PCLATU   #xffb)
1014 (define PCLATH   #xffa)
1015 (define PCL      #xff9)
1016 (define TBLPTRU  #xff8)
1017 (define TBLPTRH  #xff7)
1018 (define TBLPTRL  #xff6)
1019 (define TABLAT   #xff5)
1020 (define PRODH    #xff4)
1021 (define PRODL    #xff3)
1022 (define INDF0    #xfef)
1023 (define POSTINC0 #xfee)
1024 (define POSTDEC0 #xfed)
1025 (define PREINC0  #xfec)
1026 (define PLUSW0   #xfeb)
1027 (define FSR0H    #xfea)
1028 (define FSR0L    #xfe9)
1029 (define WREG     #xfe8)
1030 (define INDF1    #xfe7)
1031 (define POSTINC1 #xfe6)
1032 (define POSTDEC1 #xfe5)
1033 (define PREINC1  #xfe4)
1034 (define PLUSW1   #xfe3)
1035 (define FSR1H    #xfe2)
1036 (define FSR1L    #xfe1)
1037 (define BSR      #xfe0)
1038 (define INDF2    #xfdf)
1039 (define POSTINC2 #xfde)
1040 (define POSTDEC2 #xfdd)
1041 (define PREINC2  #xfdc)
1042 (define PLUSW2   #xfdb)
1043 (define FSR2H    #xfda)
1044 (define FSR2L    #xfd9)
1045 (define STATUS   #xfd8)
1046 (define TMR1H    #xfcf)
1047 (define TMR1L    #xfce)
1048 (define PORTE    #xf84)
1049 (define PORTD    #xf83)
1050 (define PORTC    #xf82)
1051 (define PORTB    #xf81)
1052 (define PORTA    #xf80)
1053
1054 (define file-reg-names '(
1055   (#xfff . TOSU)
1056   (#xffe . TOSH)
1057   (#xffd . TOSL)
1058   (#xffc . STKPTR)
1059   (#xffb . PCLATU)
1060   (#xffa . PCLATH)
1061   (#xff9 . PCL)
1062   (#xff8 . TBLPTRU)
1063   (#xff7 . TBLPTRH)
1064   (#xff6 . TBLPTRL)
1065   (#xff5 . TABLAT)
1066   (#xff4 . PRODH)
1067   (#xff3 . PRODL)
1068   (#xfef . INDF0)
1069   (#xfee . POSTINC0)
1070   (#xfed . POSTDEC0)
1071   (#xfec . PREINC0)
1072   (#xfeb . PLUSW0)
1073   (#xfea . FSR0H)
1074   (#xfe9 . FSR0L)
1075   (#xfe8 . WREG)
1076   (#xfe7 . INDF1)
1077   (#xfe6 . POSTINC1)
1078   (#xfe5 . POSTDEC1)
1079   (#xfe4 . PREINC1)
1080   (#xfe3 . PLUSW1)
1081   (#xfe2 . FSR1H)
1082   (#xfe1 . FSR1L)
1083   (#xfe0 . BSR)
1084   (#xfdf . INDF2)
1085   (#xfde . POSTINC2)
1086   (#xfdd . POSTDEC2)
1087   (#xfdc . PREINC2)
1088   (#xfdb . PLUSW2)
1089   (#xfda . FSR2H)
1090   (#xfd9 . FSR2L)
1091   (#xfd8 . STATUS)
1092   (#xfd7 . TMR0H)
1093   (#xfd6 . TMR0L)
1094   (#xfd5 . T0CON)
1095   (#xfd3 . OSCCON)
1096   (#xfcf . TMR1H)
1097   (#xfce . TMR1L)
1098   (#xfcd . T1CON)
1099   (#xfc1 . ADCON1)
1100   (#xfdb . PLUSW2)
1101   (#xfa1 . PIR2)
1102   (#xfa0 . PIE2)
1103   (#xf9e . PIR1)
1104   (#xf9d . PIE1)
1105   (#xf93 . TRISB)
1106   (#xf92 . TRISA)
1107   (#xf8a . LATB)
1108   (#xf89 . LATA)
1109   (#xf84 . PORTE)
1110   (#xf83 . PORTD)
1111   (#xf82 . PORTC)
1112   (#xf81 . PORTB)
1113   (#xf80 . PORTA)
1114 ))
1115
1116 (define C  0)
1117 (define DC 1)
1118 (define Z  2)
1119 (define OV 3)
1120 (define N  4)
1121
1122 ;------------------------------------------------------------------------------
1123
1124 (define (label-offset-reference label offset)
1125   (asm-at-assembly
1126     (lambda (self)
1127       2)
1128     (lambda (self)
1129       (asm-16 (+ (asm-label-pos label) offset)))))
1130
1131 (define (label-instr label opcode)
1132   (asm-at-assembly
1133     (lambda (self)
1134       2)
1135     (lambda (self)
1136       (let ((pos (asm-label-pos label)))
1137         (asm-8 (+ (quotient pos 256) opcode))
1138         (asm-8 (modulo pos 256))))))
1139
1140 ;------------------------------------------------------------------------------
1141
1142 (define irda_send_newline               #x0078)
1143 (define irda_send                       #x007E)
1144 (define irda_recv_with_1_sec_timeout    #x00A2)
1145 (define irda_recv                       #x00A4)
1146 (define sec_sleep                       #x00B0)
1147 (define msec_sleep                      #x00B6)
1148 (define delay_7                         #x00D4)
1149 (define led_set                         #x00D6)
1150 (define bit_set                         #x00EC)
1151 (define FLASH_execute_erase             #x0106)
1152 (define FLASH_execute_write             #x0108)
1153 (define parse_hex_byte                  #x0184)
1154 (define parse_hex_digit                 #x0194)
1155 (define irda_send_hex                   #x01AE)
1156 (define irda_send_nibble                #x01B6)
1157
1158 ;------------------------------------------------------------------------------