pic18-sim.scm

   1 ;;; File: "pic18-sim.scm"
   2
   3 (load "pic18")
   4
   5 ;------------------------------------------------------------------------------
   6
   7 (define pic18-ram   #f)
   8 (define pic18-rom   #f)
   9 (define pic18-stack #f)
  10 (define pic18-pc    #f)
  11 (define pic18-wreg  #f)
  12
  13 (define pic18-carry-flag    #f)
  14 (define pic18-deccarry-flag #f)
  15 (define pic18-zero-flag     #f)
  16 (define pic18-overflow-flag #f)
  17 (define pic18-negative-flag #f)
  18
  19 (define pic18-cycles #f)
  20 (define pic18-exit #f)
  21
  22 (define (get-ram adr)
  23   (cond ((= adr TOSU)
  24          (bitwise-and (arithmetic-shift (get-tos) -16) #xff))
  25         ((= adr TOSH)
  26          (bitwise-and (arithmetic-shift (get-tos) -8) #xff))
  27         ((= adr TOSL)
  28          (bitwise-and (get-tos) #xff))
  29         ((= adr PCL)
  30          (set-ram PCLATU (bitwise-and (arithmetic-shift (get-pc) -16) #x1f))
  31          (set-ram PCLATH (bitwise-and (arithmetic-shift (get-pc) -8)  #xff))
  32          (bitwise-and (get-pc) #xfe))
  33         ((= adr STATUS)
  34          (+ pic18-carry-flag
  35             (arithmetic-shift pic18-deccarry-flag 1)
  36             (arithmetic-shift pic18-zero-flag 2)
  37             (arithmetic-shift pic18-overflow-flag 3)
  38             (arithmetic-shift pic18-negative-flag 4)))
  39         ((assq adr (list (cons INDF0 (cons FSR0H FSR0L))
  40                          (cons INDF1 (cons FSR1H FSR1L))
  41                          (cons INDF2 (cons FSR2H FSR2L))))
  42          => (lambda (x)
  43               (get-ram (bitwise-ior
  44                         (arithmetic-shift (bitwise-and (u8vector-ref pic18-ram
  45                                                                      (cadr x))
  46                                                        #xf)
  47                                           8)
  48                         (u8vector-ref pic18-ram
  49                                       (cddr x))))))
  50         ;; TODO pre/post inc/dec 0..2
  51         (else
  52          (u8vector-ref pic18-ram adr))))
  53
  54 (define (set-ram adr byte)
  55   (cond ((= adr TOSU)
  56          (set-tos (+ (bitwise-and (get-tos) #x00ffff)
  57                      (arithmetic-shift (bitwise-and byte #x1f) 16))))
  58         ((= adr TOSH)
  59          (set-tos (+ (bitwise-and (get-tos) #x1f00ff)
  60                      (arithmetic-shift byte 8))))
  61         ((= adr TOSL)
  62          (set-tos (+ (bitwise-and (get-tos) #x1fff00)
  63                      byte)))
  64         ((= adr PCL)
  65          (set-pc (+ (bitwise-and (arithmetic-shift (get-ram PCLATU) 16) #x1f)
  66                     (bitwise-and (arithmetic-shift (get-ram PCLATH) 8) #xff)
  67                     (bitwise-and byte #xfe))))
  68         ((= adr STATUS)
  69          (set! pic18-carry-flag    (bitwise-and byte 1))
  70          (set! pic18-deccarry-flag (arithmetic-shift (bitwise-and byte 2) -1))
  71          (set! pic18-zero-flag     (arithmetic-shift (bitwise-and byte 4) -2))
  72          (set! pic18-overflow-flag (arithmetic-shift (bitwise-and byte 8) -3))
  73          (set! pic18-negative-flag (arithmetic-shift (bitwise-and byte 16) -4)))
  74         ((assq adr (list (cons INDF0 (cons FSR0H FSR0L))
  75                          (cons INDF1 (cons FSR1H FSR1L))
  76                          (cons INDF2 (cons FSR2H FSR2L))))
  77          => (lambda (x)
  78               (set-ram (bitwise-ior ;; TODO factor common code with get-ram ?
  79                         (arithmetic-shift (bitwise-and (u8vector-ref pic18-ram
  80                                                                      (cadr x))
  81                                                        #xf)
  82                                           8)
  83                         (u8vector-ref pic18-ram
  84                                       (cddr x)))
  85                        byte)))
  86         ;; TODO all other special array registers
  87         (else
  88          (u8vector-set! pic18-ram adr byte))))
  89
  90 (define (get-rom adr)
  91   (u8vector-ref pic18-rom adr))
  92
  93 (define (set-rom adr byte)
  94   (u8vector-set! pic18-rom adr byte))
  95
  96 (define (get-stack adr)
  97   (vector-ref pic18-stack adr))
  98
  99 (define (set-stack adr pc)
 100   (vector-set! pic18-stack adr pc))
 101
 102 (define (get-pc)
 103   pic18-pc)
 104
 105 (define (set-pc pc)
 106   (set! pic18-pc pc))
 107
 108 (define (get-sp)
 109   (bitwise-and (get-ram STKPTR) #x1f))
 110
 111 (define (set-sp sp)
 112   (set-ram STKPTR
 113            (bitwise-ior sp
 114                         (bitwise-and (get-ram STKPTR) #xe0))))
 115
 116 (define (get-tos)
 117   (vector-ref pic18-stack (- (get-sp) 1)))
 118
 119 (define (set-tos pc)
 120   (vector-set! pic18-stack (- (get-sp) 1) pc))
 121
 122 (define (stack-push pc)
 123   (set-sp (+ (get-sp) 1))
 124   (set-tos pc))
 125
 126 (define (stack-pop)
 127   (set-pc (get-tos))
 128   (set-sp (- (get-sp) 1)))
 129
 130 (define (get-bsr)
 131   (bitwise-and (get-ram BSR) #x0f))
 132
 133 (define (get-wreg)
 134   pic18-wreg)
 135
 136 (define (set-wreg byte)
 137   (set! pic18-wreg byte))
 138
 139 (define (zero-flag?)
 140   (not (= 0 pic18-zero-flag)))
 141
 142 (define (set-zero-flag flag)
 143   (set! pic18-zero-flag flag))
 144
 145 (define (negative-flag?)
 146   (not (= 0 pic18-negative-flag)))
 147
 148 (define (set-negative-flag flag)
 149   (set! pic18-negative-flag flag))
 150
 151 (define (carry-flag?)
 152   (not (= 0 pic18-carry-flag)))
 153
 154 (define (set-carry-flag flag)
 155   (set! pic18-carry-flag flag))
 156
 157 (define (deccarry-flag?)
 158   (not (= 0 pic18-deccarry-flag)))
 159
 160 (define (set-deccarry-flag flag)
 161   (set! pic18-deccarry-flag flag))
 162
 163 (define (overflow-flag?)
 164   (not (= 0 pic18-overflow-flag)))
 165
 166 (define (set-overflow-flag flag)
 167   (set! pic18-overflow-flag flag))
 168
 169 (define (pic18-sim-setup)
 170   (set! pic18-ram   (make-u8vector #x1000 0))
 171   (set! pic18-rom   (make-u8vector #x10000 0))
 172   (set! pic18-stack (make-vector #x1f 0))
 173   (set-pc 0)
 174   (set-wreg 0)
 175   (set! pic18-carry-flag    0)
 176   (set! pic18-deccarry-flag 0)
 177   (set! pic18-zero-flag     0)
 178   (set! pic18-overflow-flag 0)
 179   (set! pic18-negative-flag 0))
 180
 181 (define (pic18-sim-cleanup)
 182   (set! pic18-ram   #f)
 183   (set! pic18-rom   #f)
 184   (set! pic18-stack #f))
 185
 186 ;------------------------------------------------------------------------------
 187
 188 (define (last-pc)
 189   (let ((pc (- (get-pc) 2)))
 190     (list (get-sp) " " (- pic18-cycles 1) " "
 191           (substring (number->string (+ #x1000000 pc) 16) 1 7)
 192           "     ")))
 193
 194 (define (illegal-opcode opcode)
 195   (if trace-instr
 196       (print (list (last-pc) "  *illegal*")))
 197   (error "illegal opcode" opcode))
 198
 199 (define decode-vector
 200   (make-vector 256 illegal-opcode))
 201
 202 (define (decode-opcode opcode-bits shift action)
 203   (if (< shift 8)
 204       (error "shift=" shift))
 205   (let ((n (arithmetic-shift 1 (- shift 8)))
 206         (base (arithmetic-shift opcode-bits (- shift 8))))
 207     (let loop ((i 0))
 208       (if (< i n)
 209           (begin
 210             (vector-set! decode-vector (+ base i) action)
 211             (loop (+ i 1)))))))
 212
 213 (define (byte-oriented opcode mnemonic flags-changed operation)
 214   (byte-oriented-aux opcode mnemonic flags-changed operation 'wreg))
 215 (define (byte-oriented-file opcode mnemonic flags-changed operation)
 216   (byte-oriented-aux opcode mnemonic flags-changed operation 'file))
 217 (define (byte-oriented-wide opcode mnemonic flags-changed operation dest)
 218   ;; for use with instructions that have results more than a byte wide, such
 219   ;; as multiplication. the result goes at the given addresses
 220   (byte-oriented-aux opcode mnemonic flags-changed operation dest)) ;; TODO do the same for literals
 221
 222 (define (byte-oriented-aux opcode mnemonic flags-changed operation dest)
 223   (let* ((f (bitwise-and opcode #xff))
 224          (adr (if (= 0 (bitwise-and opcode #x100))
 225                   (if (= 0 (bitwise-and f #x80)) f (+ f #xf00))
 226                   (+ f (arithmetic-shift (get-bsr) 8)))))
 227     (if trace-instr
 228         (print (list (last-pc) "        " mnemonic "    "
 229                        (let ((x (assv adr file-reg-names)))
 230                          (if x (cdr x) (list "0x" (number->string adr 16))))
 231                        (if (or (eq? dest 'wreg)
 232                                (= 0 (bitwise-and opcode #x200)))
 233                            ", w"
 234                            "")
 235                        "")))
 236     (let* ((result (operation (get-ram adr)))
 237            (result-8bit (bitwise-and result #xff)))
 238       (cond ((list? dest)
 239              ;; result is more than a byte wide (i.e. multiplication)
 240              ;; put it in the right destinations (dest is a list of addresses)
 241              (let loop ((dest dest) (result result))
 242                (if (not (null? dest))
 243                    ;; the head of the list is the lsb
 244                    (begin (set-ram (car dest) (bitwise-and result #xff))
 245                           (loop (cdr dest) (arithmetic-shift result -8))))))
 246             ((or (eq? dest 'file) (not (= 0 (bitwise-and opcode #x200))))
 247              ;; the result goes in memory (file)
 248              (set-ram adr result-8bit))
 249             ((eq? dest 'wreg)
 250              ;; result goes in wreg
 251              (set-wreg result-8bit)))
 252       (if (not (eq? flags-changed 'none))
 253           (begin
 254             (set-zero-flag (if (= 0 result-8bit) 1 0))
 255             (if (not (eq? flags-changed 'z))
 256                 (begin
 257                   (set-negative-flag (if (> result-8bit #x7f) 1 0))
 258                   (if (not (eq? flags-changed 'z-n))
 259                       (begin
 260                         (set-carry-flag (if (or (> result #xff)
 261                                                 (< result 0))
 262                                             1 0))
 263                         (if (not (eq? flags-changed 'c-z-n))
 264                             (begin
 265                               (set-deccarry-flag 0);;;;;;;;;;;;;;
 266                               (set-overflow-flag 0))))))))))));;;;;;;;;;;;;;
 267
 268 (define (bit-oriented opcode mnemonic operation)
 269   (let* ((f (bitwise-and opcode #xff))
 270          (adr (if (= 0 (bitwise-and opcode #x100))
 271                   (if (= 0 (bitwise-and f #x80)) f (+ f #xf00))
 272                   (+ f (arithmetic-shift (get-bsr) 8))))
 273          (b (bitwise-and (arithmetic-shift opcode -9) 7)))
 274     (if trace-instr
 275         (print (list (last-pc) "        " mnemonic "    "
 276                        (let ((x (assv adr file-reg-names)))
 277                          (if x (cdr x) (list "0x" (number->string adr 16))))
 278                        ", "
 279                        (if (= adr STATUS)
 280                            (cdr (assv b '((0 . C)
 281                                           (1 . DC)
 282                                           (2 . Z)
 283                                           (3 . OV)
 284                                           (4 . N)
 285                                           (5 . 5)
 286                                           (6 . 6)
 287                                           (7 . 7))))
 288                            b)
 289                        "")))
 290     (let* ((result (operation (get-ram adr) b))
 291            (result-8bit (bitwise-and result #xff)))
 292       (set-ram adr result-8bit))))
 293
 294 (define (short-relative-branch opcode mnemonic branch)
 295   (let* ((n (bitwise-and opcode #xff))
 296          (adr (+ (get-pc) (* 2 (if (> n #x7f) (- n #x100) n)))))
 297     (if trace-instr
 298         (print (list (last-pc) "        " mnemonic "    "
 299                        "0x"
 300                        (number->string adr 16)
 301                        "")))
 302     (if (branch)
 303         (begin
 304           (get-program-mem)
 305           (set-pc adr)))))
 306
 307 (define (long-relative-branch opcode mnemonic call?)
 308   (let* ((n (bitwise-and opcode #x7ff))
 309          (adr (+ (get-pc) (* 2 (if (> n #x3ff) (- n #x800) n)))))
 310     (if trace-instr
 311         (print (list (last-pc) "        " mnemonic "    "
 312                        "0x"
 313                        (number->string adr 16)
 314                        "")))
 315     (if call?
 316         (stack-push (get-pc)))
 317     (get-program-mem)
 318     (set-pc adr)))
 319
 320 (define (call-branch opcode mnemonic)
 321   (let ((adr (* 2 (+ (bitwise-and opcode #xff)
 322                      (arithmetic-shift (bitwise-and (get-program-mem) #xfff) 8)))))
 323     (if trace-instr
 324         (print (list (last-pc) "        " mnemonic "    "
 325                        "0x"
 326                        (number->string adr 16)
 327                        (if (= 0 (bitwise-and opcode #x100))
 328                            ""
 329                            ", FAST")
 330                        "")))
 331     (stack-push (get-pc))
 332     (if (not (= 0 (bitwise-and opcode #x100)))
 333         (error "call fast not implemented"))
 334     (set-pc adr)))
 335
 336 (define (goto-branch opcode mnemonic)
 337   (let ((adr (* 2 (+ (bitwise-and opcode #xff)
 338                      (arithmetic-shift (bitwise-and (get-program-mem) #xfff) 8)))))
 339     (if trace-instr
 340         (print (list (last-pc) "        " mnemonic "    "
 341                        "0x"
 342                        (number->string adr 16)
 343                        "")))
 344     (set-pc adr)))
 345
 346 (define (literal-operation opcode mnemonic flags-changed operation)
 347   (let ((k (bitwise-and opcode #xff)))
 348     (if trace-instr
 349         (print (list (last-pc) "        " mnemonic "    "
 350                        (if (< k 10) k (list "0x" (number->string k 16)))
 351                        "")))
 352     (let* ((result (operation k))
 353            (result-8bit (bitwise-and result #xff)))
 354       (set-wreg result-8bit)
 355       (if (not (eq? flags-changed 'none))
 356           (begin
 357             (set-zero-flag (if (= 0 result-8bit) 1 0))
 358             (if (not (eq? flags-changed 'z))
 359                 (begin
 360                   (set-negative-flag (if (> result-8bit #x7f) 1 0))
 361                   (if (not (eq? flags-changed 'z-n))
 362                       (begin
 363                         (set-carry-flag (if (> result #xff) 1 0))
 364                         (if (not (eq? flags-changed 'c-z-n))
 365                             (begin
 366                               (set-deccarry-flag 0);;;;;;;;;;;;;;
 367                               (set-overflow-flag 0))))))))))));;;;;;;;;;;;;;
 368
 369 (define (get-program-mem)
 370   (set! pic18-cycles (+ pic18-cycles 1))
 371   (let* ((pc (get-pc))
 372          (lsb (get-rom pc))
 373          (msb (get-rom (+ pc 1))))
 374     (set-pc (+ (get-pc) 2))
 375     (+ (arithmetic-shift msb 8) lsb)))
 376
 377 (define (skip)
 378   (get-program-mem))
 379
 380 (define (hex n)
 381   (substring (number->string (+ #x100 n) 16) 1 3))
 382
 383 (define (dump-mem)
 384
 385   (print "      ")
 386   (let loop ((i 0))
 387     (if (< i 10)
 388         (begin
 389           (print (list (hex (u8vector-ref pic18-ram i)) " "))
 390           (loop (+ i 1)))))
 391   (print (list "  WREG=" (hex (get-wreg)) "\n")))
 392
 393 (define (pic18-execute)
 394   (set! pic18-exit #f)
 395   (set! pic18-cycles 0)
 396   (if trace-instr
 397       (print "                          "))
 398   (let loop ()
 399     (if trace-instr
 400         (dump-mem))
 401     (if pic18-exit
 402         (begin
 403           (print (list "WREG = d'" (get-wreg) "'\n")))
 404         (let ((opcode (get-program-mem)))
 405           (let ((proc (vector-ref decode-vector (arithmetic-shift opcode -8))))
 406             (proc opcode)
 407             (loop))))))
 408
 409 (define trace-instr #t)
 410
 411 (define (carry)
 412   (if (> pic18-carry-flag 0)
 413       (begin (set! pic18-carry-flag #f)
 414              1)
 415       0))
 416
 417 ;------------------------------------------------------------------------------
 418
 419 ; Byte-oriented file register operations.
 420
 421 (decode-opcode #b001001 10
 422   (lambda (opcode)
 423     (byte-oriented opcode "addwf" 'c-dc-z-ov-n
 424      (lambda (f)
 425        (+ f (get-wreg))))))
 426
 427 (decode-opcode #b001000 10
 428   (lambda (opcode)
 429     (byte-oriented opcode "addwfc" 'c-dc-z-ov-n
 430      (lambda (f)
 431        (+ f (get-wreg) (carry))))))
 432
 433 (decode-opcode #b000101 10
 434   (lambda (opcode)
 435     (byte-oriented opcode "andwf" 'z-n
 436      (lambda (f)
 437        (bitwise-and f (get-wreg))))))
 438
 439 (decode-opcode #b0110101 9
 440   (lambda (opcode)
 441     (byte-oriented-file opcode "clrf" 'z
 442      (lambda (f)
 443        0))))
 444
 445 (decode-opcode #b000111 10
 446   (lambda (opcode)
 447     (byte-oriented opcode "comf" 'z-n
 448      (lambda (f)
 449        (bitwise-not f)))))
 450
 451 (decode-opcode #b0110001 9
 452   (lambda (opcode)
 453     (byte-oriented-file opcode "cpfseq" 'none
 454      (lambda (f)
 455        (if (= f (get-wreg)) (skip))
 456        f))))
 457
 458 (decode-opcode #b0110010 9
 459   (lambda (opcode)
 460     (byte-oriented-file opcode "cpfsgt" 'none
 461      (lambda (f)
 462        (if (> f (get-wreg)) (skip))
 463        f))))
 464
 465 (decode-opcode #b0110000 9
 466   (lambda (opcode)
 467     (byte-oriented-file opcode "cpfslt" 'none
 468      (lambda (f)
 469        (if (< f (get-wreg)) (skip))
 470        f))))
 471
 472 (decode-opcode #b000001 10
 473   (lambda (opcode)
 474     (byte-oriented opcode "decf" 'c-dc-z-ov-n
 475      (lambda (f)
 476        (- f 1)))))
 477
 478 (decode-opcode #b001011 10
 479   (lambda (opcode)
 480     (byte-oriented opcode "decfsz" 'none
 481      (lambda (f)
 482        (if (= f 1) (skip))
 483        (- f 1)))))
 484
 485 (decode-opcode #b010011 10
 486   (lambda (opcode)
 487     (byte-oriented opcode "dcfsnz" 'none
 488      (lambda (f)
 489        (if (not (= f 1)) (skip))
 490        (- f 1)))))
 491
 492 (decode-opcode #b001010 10
 493   (lambda (opcode)
 494     (byte-oriented opcode "incf" 'c-dc-z-ov-n
 495      (lambda (f)
 496        (+ f 1)))))
 497
 498 (decode-opcode #b001111 10
 499   (lambda (opcode)
 500     (byte-oriented opcode "incfsz" 'none
 501      (lambda (f)
 502        (if (= f #xff) (skip))
 503        (+ f 1)))))
 504
 505 (decode-opcode #b010010 10
 506   (lambda (opcode)
 507     (byte-oriented opcode "infsnz" 'none
 508      (lambda (f)
 509        (if (not (= f #xff)) (skip))
 510        (+ f 1)))))
 511
 512 (decode-opcode #b000100 10
 513   (lambda (opcode)
 514     (byte-oriented opcode "iorwf" 'z-n
 515      (lambda (f)
 516        (bitwise-ior f (get-wreg))))))
 517
 518 (decode-opcode #b010100 10
 519   (lambda (opcode)
 520     (byte-oriented opcode "movf" 'z-n
 521      (lambda (f)
 522        f))))
 523
 524 (decode-opcode #b1100 12
 525   (lambda (opcode)
 526     (let* ((src (bitwise-and opcode #xfff))
 527            ;; the destination is in the second 16-bit part, need to fetch
 528            (dst (bitwise-and (get-program-mem) #xfff)))
 529       (if trace-instr
 530           (print (list (last-pc) "      movff   "
 531                        (let ((x (assv src file-reg-names)))
 532                          (if x (cdr x) (list "0x" (number->string src 16))))
 533                        ", "
 534                        (let ((x (assv dst file-reg-names)))
 535                          (if x (cdr x) (list "0x" (number->string dst 16)))) ;; TODO printing 2 args ruins the formatting
 536                        "")))
 537       (set-ram dst (get-ram src)))))
 538
 539 (decode-opcode #b0110111 9
 540   (lambda (opcode)
 541     (byte-oriented-file opcode "movwf" 'none
 542      (lambda (f)
 543        (get-wreg)))))
 544
 545 (decode-opcode #b0000001 9
 546   (lambda (opcode)
 547     (byte-oriented-wide opcode "mulwf" 'none
 548      (lambda (f)
 549        (* f (get-wreg)))
 550      (list PRODL PRODH))))
 551
 552 (decode-opcode #b0110110 9
 553   (lambda (opcode)
 554     (byte-oriented-file opcode "negf" 'c-dc-z-ov-n
 555      (lambda (f)
 556        (- f)))))
 557
 558 (decode-opcode #b001101 10
 559   (lambda (opcode)
 560     (byte-oriented opcode "rlcf" 'c-z-n
 561      (lambda (f)
 562        ;; the carry flasg will be set automatically
 563        (+ (arithmetic-shift f 1) (carry))))))
 564
 565 (decode-opcode #b010001 10
 566   (lambda (opcode)
 567     (byte-oriented opcode "rlncf" 'z-n
 568      (lambda (f)
 569        (+ (arithmetic-shift f 1) (arithmetic-shift f -7))))))
 570
 571 (decode-opcode #b001100 10
 572   (lambda (opcode)
 573     (byte-oriented opcode "rrcf" 'c-z-n
 574      (lambda (f)
 575        (let ((r (+ (arithmetic-shift f -1) (arithmetic-shift (carry) 7))))
 576          ;; roll through carry (if the result is over #xff, carry will be set)
 577          (if (= (bitwise-and f 1) 1) (+ r #x100) r))))))
 578
 579 (decode-opcode #b010000 10
 580   (lambda (opcode)
 581     (byte-oriented opcode "rrncf" 'z-n
 582      (lambda (f)
 583        (+ (arithmetic-shift f -1) (arithmetic-shift f 7))))))
 584
 585 (decode-opcode #b0110100 9
 586   (lambda (opcode)
 587     (byte-oriented-file opcode "setf" 'z
 588      (lambda (f)
 589        #xff))))
 590
 591 (decode-opcode #b010101 10
 592   (lambda (opcode)
 593     (byte-oriented opcode "subfwb" 'c-dc-z-ov-n
 594      (lambda (f)
 595        (- (get-wreg) f (carry))))))
 596
 597 (decode-opcode #b010111 10
 598   (lambda (opcode)
 599     (byte-oriented opcode "subwf" 'c-dc-z-ov-n
 600      (lambda (f)
 601        (- f (get-wreg))))))
 602
 603 (decode-opcode #b010110 10
 604   (lambda (opcode)
 605     (byte-oriented opcode "subwfb" 'c-dc-z-ov-n
 606      (lambda (f)
 607        (- f (get-wreg) (carry))))))
 608
 609 (decode-opcode #b001110 10
 610   (lambda (opcode)
 611     (byte-oriented opcode "swapf" 'none
 612      (lambda (f)
 613        (+ (arithmetic-shift f -4) (arithmetic-shift f 4))))))
 614
 615 (decode-opcode #b0110011 9
 616   (lambda (opcode)
 617     (byte-oriented-file opcode "tstfsz" 'none
 618      (lambda (f)
 619        (if (= f 0) (skip))))))
 620
 621 (decode-opcode #b000110 10
 622   (lambda (opcode)
 623     (byte-oriented opcode "xorwf" 'z-n
 624      (lambda (f)
 625        (bitwise-xor f (get-wreg))))))
 626
 627 ; Bit-oriented file register operations.
 628
 629 (decode-opcode #b1001 12
 630   (lambda (opcode)
 631     (bit-oriented opcode "bcf"
 632      (lambda (f b)
 633        (bitwise-and f (bitwise-not (arithmetic-shift 1 b)))))))
 634
 635 (decode-opcode #b1000 12
 636   (lambda (opcode)
 637     (bit-oriented opcode "bsf"
 638      (lambda (f b)
 639        (bitwise-ior f (arithmetic-shift 1 b))))))
 640
 641 (decode-opcode #b1011 12
 642   (lambda (opcode)
 643     (bit-oriented opcode "btfsc"
 644      (lambda (f b)
 645        (if (= 0 (bitwise-and f (arithmetic-shift 1 b))) (skip))
 646        f))))
 647
 648 (decode-opcode #b1010 12
 649   (lambda (opcode)
 650     (bit-oriented opcode "btfss"
 651      (lambda (f b)
 652        (if (not (= 0 (bitwise-and f (arithmetic-shift 1 b)))) (skip))
 653        f))))
 654
 655 (decode-opcode #b0111 12
 656   (lambda (opcode)
 657     (bit-oriented opcode "btg"
 658      (lambda (f b)
 659        (bitwise-xor f (arithmetic-shift 1 b))))))
 660
 661 ; Control operations.
 662
 663 (decode-opcode #b11100010 8
 664   (lambda (opcode)
 665     (short-relative-branch opcode "bc"
 666      (lambda ()
 667        (not (= 0 (carry)))))))
 668
 669 (decode-opcode #b11100110 8
 670   (lambda (opcode)
 671     (short-relative-branch opcode "bn" negative-flag?)))
 672
 673 (decode-opcode #b11100011 8
 674   (lambda (opcode)
 675     (short-relative-branch opcode "bnc"
 676      (lambda ()
 677        (= 0 (carry))))))
 678
 679 (decode-opcode #b11100111 8
 680   (lambda (opcode)
 681     (short-relative-branch opcode "bnn" negative-flag?)))
 682
 683 (decode-opcode #b11100101 8
 684   (lambda (opcode)
 685     (short-relative-branch opcode "bnov"
 686      (lambda ()
 687        (not (overflow-flag?))))))
 688
 689 (decode-opcode #b11100001 8
 690   (lambda (opcode)
 691     (short-relative-branch opcode "bnz"
 692      (lambda ()
 693        (not (zero-flag?))))))
 694
 695 (decode-opcode #b11100100 8
 696   (lambda (opcode)
 697     (short-relative-branch opcode "bov" overflow-flag?)))
 698
 699 (decode-opcode #b11010 11
 700   (lambda (opcode)
 701     (long-relative-branch opcode "bra" #f)))
 702
 703 (decode-opcode #b11100000 8
 704   (lambda (opcode)
 705     (short-relative-branch opcode "bz" zero-flag?)))
 706
 707 (decode-opcode #b1110110 9
 708   (lambda (opcode)
 709     (call-branch opcode "call")))
 710
 711 (decode-opcode #b11101111 8
 712   (lambda (opcode)
 713     (goto-branch opcode "goto")))
 714
 715 (decode-opcode #b11011 11
 716   (lambda (opcode)
 717     (long-relative-branch opcode "rcall" #t)))
 718
 719 (decode-opcode #b1111 12
 720   (lambda (opcode)
 721     (if trace-instr
 722         (print (list (last-pc) "        nop     ")))))
 723
 724 (decode-opcode #b00000000 8
 725   (lambda (opcode)
 726     (cond ((= opcode #b0000000000000100)
 727            (if trace-instr
 728                (print (list (last-pc) " clrwdt  ")))
 729            (clrwdt opcode))
 730           ((= opcode #b0000000000000111)
 731            (if trace-instr
 732                (print (list (last-pc) " daw     ")))
 733            (daw opcode))
 734           ((= opcode #b0000000000000000)
 735            (if trace-instr
 736                (print (list (last-pc) " nop     "))))
 737           ((= opcode #b0000000000000110)
 738            (if trace-instr
 739                (print (list (last-pc) " pop     ")))
 740            (stack-pop))
 741           ((= opcode #b0000000000000101)
 742            (if trace-instr
 743                (print (list (last-pc) " push    ")))
 744            (stack-push (get-pc)))
 745           ((= opcode #b0000000011111111)
 746            (if trace-instr
 747                (print (list (last-pc) " reset   ")))
 748            (set-pc 0))
 749           ((= opcode #b0000000000010000)
 750            (if trace-instr
 751                (print (list (last-pc) " retfie  ")))
 752            (get-program-mem)
 753            (stack-pop))
 754           ((= opcode #b0000000000010001)
 755            (if trace-instr
 756                (print (list (last-pc) " retfie  FAST")))
 757            (error "retfie fast not implemented")
 758            (get-program-mem)
 759            (stack-pop))
 760           ((= opcode #b0000000000010010)
 761            (if trace-instr
 762                (print (list (last-pc) " return  ")))
 763            (get-program-mem)
 764            (stack-pop))
 765           ((= opcode #b0000000000010011)
 766            (if trace-instr
 767                (print (list (last-pc) " return  FAST")))
 768            (error "return fast not implemented")
 769            (get-program-mem)
 770            (stack-pop))
 771           ((= opcode #b0000000000000011)
 772            (if trace-instr
 773                (print (list (last-pc) " sleep   ")))
 774            (set! pic18-exit #t))
 775           (else
 776            (if trace-instr
 777                (print (list (last-pc) " ???     ")))
 778            (error "???")))))
 779
 780 ; Literal operations.
 781
 782 (decode-opcode #b00001111 8
 783   (lambda (opcode)
 784     (literal-operation opcode "addlw" 'c-dc-z-ov-n
 785      (lambda (k)
 786        (+ k (get-wreg))))))
 787
 788 (decode-opcode #b00001011 8
 789   (lambda (opcode)
 790     (literal-operation opcode "andlw" 'z-n
 791      (lambda (k)
 792        (bitwise-and k (get-wreg))))))
 793
 794 (decode-opcode #b00001001 8
 795   (lambda (opcode)
 796     (literal-operation opcode "iorlw" 'z-n
 797      (lambda (k)
 798        (bitwise-ior k (get-wreg))))))
 799
 800 '
 801 (define (lfsr f k)
 802   (make-instruction
 803    2
 804    (lambda ()
 805      (make-listing "lfsr" (file-text f) (lit-text k)))
 806    (lambda ()
 807      (asm-16 (bitmask "1110 1110 00ff kkkk" (file f) (quotient (lit k) 256)))
 808      (asm-16 (bitmask "1111 0000 kkkk kkkk" (modulo (lit k) 256))))))
 809
 810 '
 811 (define (movlb k)
 812   (make-instruction
 813    1
 814    (lambda ()
 815      (make-listing "movlb" (lit-text k)))
 816    (lambda ()
 817      (asm-16 (bitmask "0000 0001 0000 kkkk" (lit k))))))
 818
 819 (decode-opcode #b00001110 8
 820   (lambda (opcode)
 821     (literal-operation opcode "movlw" 'none
 822      (lambda (k)
 823        k))))
 824
 825 (decode-opcode #b00001101 8
 826   (lambda (opcode)
 827     (literal-operation opcode "mullw" 'none
 828      (lambda (k)
 829        (* k (get-wreg))))))
 830
 831 (decode-opcode #b00001100 8
 832   (lambda (opcode)
 833     (literal-operation opcode "retlw" 'none
 834      (lambda (k)
 835        (get-program-mem)
 836        (stack-pop)
 837        k))))
 838
 839 (decode-opcode #b00001000 8
 840   (lambda (opcode)
 841     (literal-operation opcode "sublw" 'c-dc-z-ov-n
 842      (lambda (k)
 843        (- k (get-wreg))))))
 844
 845 (decode-opcode #b00001010 8
 846   (lambda (opcode)
 847     (literal-operation opcode "xorlw" 'z-n
 848      (lambda (k)
 849        (bitwise-xor k (get-wreg))))))
 850
 851 ; Program memory operations.
 852
 853 '
 854 (define (tblrd*)
 855   (make-instruction
 856    2
 857    (lambda ()
 858      (make-listing "tblrd*"))
 859    (lambda ()
 860      (asm-16 (bitmask "0000 0000 0000 1000")))))
 861
 862 '
 863 (define (tblrd*+)
 864   (make-instruction
 865    2
 866    (lambda ()
 867      (make-listing "tblrd*+"))
 868    (lambda ()
 869      (asm-16 (bitmask "0000 0000 0000 1001")))))
 870
 871 '
 872 (define (tblrd*-)
 873   (make-instruction
 874    2
 875    (lambda ()
 876      (make-listing "tblrd*-"))
 877    (lambda ()
 878      (asm-16 (bitmask "0000 0000 0000 1010")))))
 879
 880 '
 881 (define (tblrd+*)
 882   (make-instruction
 883    2
 884    (lambda ()
 885      (make-listing "tblrd+*"))
 886    (lambda ()
 887      (asm-16 (bitmask "0000 0000 0000 1011")))))
 888
 889 '
 890 (define (tblwt*)
 891   (make-instruction
 892    2
 893    (lambda ()
 894      (make-listing "tblwt*"))
 895    (lambda ()
 896      (asm-16 (bitmask "0000 0000 0000 1100")))))
 897
 898 '
 899 (define (tblwt*+)
 900   (make-instruction
 901    2
 902    (lambda ()
 903      (make-listing "tblwt*+"))
 904    (lambda ()
 905      (asm-16 (bitmask "0000 0000 0000 1101")))))
 906
 907 '
 908 (define (tblwt*-)
 909   (make-instruction
 910    2
 911    (lambda ()
 912      (make-listing "tblwt*-"))
 913    (lambda ()
 914      (asm-16 (bitmask "0000 0000 0000 1110")))))
 915
 916 '
 917 (define (tblwt+*)
 918   (make-instruction
 919    2
 920    (lambda ()
 921      (make-listing "tblwt+*"))
 922    (lambda ()
 923      (asm-16 (bitmask "0000 0000 0000 1111")))))
 924
 925 ;------------------------------------------------------------------------------
 926
 927 (define (read-hex-file filename)
 928
 929   (define addr-width 32)
 930
 931   (define (syntax-error)
 932     (error "*** Syntax error in HEX file"))
 933
 934   (let ((f
 935          (with-exception-catcher
 936           (lambda (exc)
 937             #f)
 938           (lambda ()
 939             (open-input-file filename)))))
 940
 941     (define mem (make-vector 16 #f))
 942
 943     (define (mem-store! a b)
 944       (let loop ((m mem)
 945                  (a a)
 946                  (x (- addr-width 4)))
 947         (if (= x 0)
 948             (vector-set! m a b)
 949             (let ((i (arithmetic-shift a (- x))))
 950               (let ((v (vector-ref m i)))
 951                 (loop (or v
 952                           (let ((v (make-vector 16 #f)))
 953                             (vector-set! m i v)
 954                             v))
 955                       (- a (arithmetic-shift i x))
 956                       (- x 4)))))))
 957
 958     (define (mem->list)
 959
 960       (define (f m a n tail)
 961
 962         (define (g i a n tail)
 963           (if (>= i 0)
 964               (g (- i 1) (- a n) n (f (vector-ref m i) a n tail))
 965               tail))
 966
 967         (if m
 968             (if (= n 1)
 969                 (cons (cons (- a 1) m) tail)
 970                 (g 15 a (quotient n 16) tail))
 971             tail))
 972
 973       (f mem (expt 2 addr-width) (expt 2 addr-width) '()))
 974
 975     (define hi16
 976       0)
 977
 978     (define (read-hex-nibble)
 979       (let ((c (read-char f)))
 980         (cond ((and (char>=? c #\0) (char<=? c #\9))
 981                (- (char->integer c) (char->integer #\0)))
 982               ((and (char>=? c #\A) (char<=? c #\F))
 983                (+ 10 (- (char->integer c) (char->integer #\A))))
 984               ((and (char>=? c #\a) (char<=? c #\f))
 985                (+ 10 (- (char->integer c) (char->integer #\a))))
 986               (else
 987                (syntax-error)))))
 988
 989     (define (read-hex-byte)
 990       (let* ((a (read-hex-nibble))
 991              (b (read-hex-nibble)))
 992         (+ b (* a 16))))
 993
 994     (if f
 995         (begin
 996           (let loop1 ()
 997             (let ((c (read-char f)))
 998               (cond ((not (char? c)))
 999                     ((or (char=? c #\linefeed)
1000                          (char=? c #\return))
1001                      (loop1))
1002                     ((not (char=? c #\:))
1003                      (syntax-error))
1004                     (else
1005                      (let* ((len (read-hex-byte))
1006                             (a1 (read-hex-byte))
1007                             (a2 (read-hex-byte))
1008                             (type (read-hex-byte)))
1009                        (let* ((adr (+ a2 (* 256 a1)))
1010                               (sum (+ len a1 a2 type)))
1011                          (cond ((= type 0)
1012                                 (let loop2 ((i 0))
1013                                   (if (< i len)
1014                                       (let ((a (+ adr (* hi16 65536)))
1015                                             (b (read-hex-byte)))
1016                                         (mem-store! a b)
1017                                         (set! adr (modulo (+ adr 1) 65536))
1018                                         (set! sum (+ sum b))
1019                                         (loop2 (+ i 1))))))
1020                                ((= type 1)
1021                                 (if (not (= len 0))
1022                                     (syntax-error)))
1023                                ((= type 4)
1024                                 (if (not (= len 2))
1025                                     (syntax-error))
1026                                 (let* ((a1 (read-hex-byte))
1027                                        (a2 (read-hex-byte)))
1028                                   (set! sum (+ sum a1 a2))
1029                                   (set! hi16 (+ a2 (* 256 a1)))))
1030                                (else
1031                                 (syntax-error)))
1032                          (let ((check (read-hex-byte)))
1033                            (if (not (= (modulo (- sum) 256) check))
1034                                (syntax-error)))
1035                          (let ((c (read-char f)))
1036                            (if (or (not (or (char=? c #\linefeed)
1037                                             (char=? c #\return)))
1038                                    (not (= type 1)))
1039                                (loop1)))))))))
1040
1041           (close-input-port f)
1042
1043           (mem->list))
1044         (begin
1045           (error "*** Could not open the HEX file")
1046           #f))))
1047
1048 ;------------------------------------------------------------------------------
1049
1050 (define (execute-hex-file filename)
1051   (let ((program (read-hex-file filename)))
1052     (pic18-sim-setup)
1053     (for-each (lambda (x) (set-rom (car x) (cdr x))) program)
1054     (pic18-execute)
1055     (pic18-sim-cleanup)))