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