pic18-sim.scm

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