pic18-sim.scm

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