pic18-sim.scm

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