pic18.scm

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