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