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