anchor.diff:  ;;;;    You should have received a copy of the GNU Affero General Public License
   ;;;;    along with this program.  If not, see <http://www.gnu.org/licenses/>
   ;;;;**************************************************************************
  +(defpackage "EXAMPLE-SOFT-OPCODES"
  +  (:use "COMMON-LISP")
  +  (:shadow "DISASSEMBLE"))
  +(in-package "EXAMPLE-SOFT-OPCODES")
  +
  +
  +#+emacs (progn
  +          (cl-indent 'src-instruction 1)
  +          (cl-indent 'dst-instruction 1)
  +          (cl-indent 'acc-instruction 1)
  +          (cl-indent 'jmp-instruction 1))
  +
   
   
   ;;; First we define the processor (as a virtual machine here, but the
   ;;; same could be done in real hardware).
  -
  +(defconstant +bytes-per-word+ 8)
   (deftype word () '(unsigned-byte 64))
   
   (defparameter *memory-size* 65536 "Number of words in the memory") 
  
positive.code: (defconstant +illegal-instruction-trap+ 2)
  (defconstant +invalid-address-trap+     3)
  
  
  
  (defun valid-address-p (address)
    (and (<= 0 address) (< address *memory-size*)))
  
  (defun word (value) (logand value +word-mask+))
  
  (defun load-machine (machine address words)
    "Loads a code vector WORDS in the MACHINE memory at the given ADDRESS."
    (replace (machine-memory machine) words :start1 address)
    machine)
  
  (defun dump-machine (machine address length)
    "Dumps the MACHINE memory starting from ADDRESS, for LENGTH words."
    (loop
       :repeat length
       :for a :from address
       :do (format t "~4,'0X: ~16,'0X  ~:*~D~%"
                   a (aref (machine-memory machine) a)))
    machine)
  
  (defun run (machine &key (verbose nil) (step nil))
    "Run the machine.
  When verbose is true, prints the instructions and traps executed.
  When step is true, executes only one step."
    (loop :named :machine :do
       (let ((pc (machine-pc machine)))
         (if (valid-address-p pc)
             (let* ((instruction (aref (machine-memory machine) pc))
                    (opcode (opcode instruction))
                    (src    (src    instruction))
                    (dst    (dst    instruction)))
               (flet ((trap (machine trap-address)
                        (when verbose
                          (format t "~4,'0X: ~A trap~%" (machine-pc machine)
                                  (ecase trap-address
                                    (#.+illegal-instruction-trap+ "Illegal instruction")
                                    (#.+invalid-address-trap+     "Invalid address"))))
                        (shiftf (aref (machine-memory machine) +save-address+)
                                (machine-pc machine)
                                (aref (machine-memory machine) trap-address))))
                 #+emacs (progn
                           (cl-indent 'src-instruction 1)
                           (cl-indent 'dst-instruction 1)
                           (cl-indent 'acc-instruction 1)
                           (cl-indent 'jmp-instruction 1))
                 (macrolet ((src-instruction (instruction-form &body body)
                              `(cond
                                 ((and verbose (format t "~4,'0X: ~S~%" pc ,instruction-form)))
                                 ((not (valid-address-p src))
                                  (trap machine +invalid-address-trap+))
                                 ((not (zerop dst))
                                  (trap machine +invalid-address-trap+))
                                 (t
                                  ,@body
                                  (incf (machine-pc machine)))))
                            (dst-instruction (instruction-form &body body)
                              `(cond
                                 ((and verbose (format t "~4,'0X: ~S~%" pc ,instruction-form)))
                                 ((not (zerop src))
                                  (trap machine +invalid-address-trap+))
                                 ((not (valid-address-p dst))
                                  (trap machine +invalid-address-trap+))
                                 (t
                                  ,@body
                                  (incf (machine-pc machine)))))
                            (acc-instruction (instruction-form &body body)
                              `(cond
                                 ((and verbose (format t "~4,'0X: ~S~%" pc ,instruction-form)))
                                 ((not (zerop src))
                                  (trap machine +invalid-address-trap+))
                                 ((not (zerop dst))
                                  (trap machine +invalid-address-trap+))
                                 (t
                                  ,@body
                                  (incf (machine-pc machine)))))
                            (jmp-instruction (instruction-form &body body)
                              `(cond
                                 ((and verbose (format t "~4,'0X: ~S~%" pc ,instruction-form)))
                                 ((not (valid-address-p src))
                                  (trap machine +invalid-address-trap+))
                                 ((not (zerop dst))
                                  (trap machine +invalid-address-trap+))
                                 (t
                                  ,@body))))
                   (if (zerop (ldb (byte 4 0) opcode))
                       (case (ldb (byte 4 4) opcode)
                         ;; Notice not all instructions are implemented:
                         ;; 0000 move src,dst
                         ;; 0001 load src,acc
                         (#b0001
                          (src-instruction `(load ,src acc)
                            (setf (machine-accumulator machine)
                                  (aref (machine-memory machine) src))))
                         ;; 0010 store acc,dst
                         (#b0010
                          (dst-instruction `(store acc ,dst)
                            (setf (aref (machine-memory machine) dst)
                                  (machine-accumulator machine))))
                         ;; 0100 add src,acc
                         (#b0100
                          (src-instruction `(add ,src acc)
                            (setf (machine-accumulator machine)
                                  (word (+ (machine-accumulator machine)
                                           (aref (machine-memory machine) src))))))
                         ;; 0101 sub src,acc
                         ;; 0110 mul src,acc
                         ;; 0111 div src,acc
                         ;; 1000 not acc
                         (#b1000
                          (acc-instruction `(not acc)
                            (setf (machine-accumulator machine)
                                  (word (lognot (machine-accumulator machine))))))
                         ;; 1001 neg acc
                         ;; (#b10100000 (lshift src acc))
                         (#b1010
                          (src-instruction `(lshift ,src acc)
                            (setf (machine-accumulator machine)
                                  (word (ash (machine-accumulator machine)
                                             (aref (machine-memory machine) src))))))
                         ;; (#b10110000 (rshift src acc))
                         (#b1011
                          (src-instruction `(rshift ,src acc)
                            (setf (machine-accumulator machine)
                                  (word (ash (machine-accumulator machine)
                                             (- (aref (machine-memory machine) src)))))))
                         ;; (#b11000000 (and src acc))
                         (#b1100
                          (src-instruction `(and ,src acc)
                            (setf (machine-accumulator machine)
                                  (word (logand (machine-accumulator machine)
                                                (aref (machine-memory machine) src))))))
                         ;; (#b11010000 (or  src acc))
                         (#b1101
                          (src-instruction `(or ,src acc)
                            (setf (machine-accumulator machine)
                                  (word (logior (machine-accumulator machine)
                                                (aref (machine-memory machine) src))))))
                         ;; 1110 jzero src
                         (#b1110
                          (jmp-instruction `(jzero ,src)
                            (if (zerop (machine-accumulator machine))
                                (setf (machine-pc machine) src)
                                (incf (machine-pc machine)))))
                         ;; 1111 jump  src
                         (#b1111
                          (jmp-instruction `(jump ,src)
                            (setf (machine-pc machine) src)))
                         (otherwise
                          (trap machine +illegal-instruction-trap+)))
                       (case opcode
                         (#b11111111
                          (jmp-instruction `(halt)
                            (return-from :machine)))
                         (otherwise
                          (trap machine +illegal-instruction-trap+)))))))
             (trap machine +invalid-address-trap+)))
       :until step))
  
  
  ;;; Next we write a little LAP assembler.
  ;;; Notice we may assemble instructions that are not implemented (yet)
  ;;; in hardware.
  
  (defparameter *instructions*
    '((#b00000000 (move src dst))
      (#b00010000 (load src acc))
      (#b00100000 (store acc dst))
      (#b01000000 (add src acc))
      (#b01010000 (sub src acc))
      (#b01100000 (mul src acc))
  
negative.code:  ;;;; -*- mode:lisp;coding:utf-8 -*-
  ;;;;**************************************************************************
  ;;;;FILE:               example-soft-opcodes.lisp
  ;;;;LANGUAGE:           Common-Lisp
  