Created
June 30, 2009 07:19
-
-
Save fffej/138049 to your computer and use it in GitHub Desktop.
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
(defstruct virtualmachine :mem :counter :inport :outport :status :firstrun :user) | |
(defn increment-counter | |
[vm] | |
(assoc vm :counter (inc (:counter vm)))) | |
(defn memory-put | |
"Update the memory specified by the key with the address to the given value" | |
[vm key addr val] | |
(assoc vm key (assoc (key vm) addr val))) | |
(defn memory-read | |
"Return the value in key at address" | |
[vm key addr] | |
((key vm) addr)) | |
(defn mem-read | |
[vm addr] | |
((:mem vm) addr)) | |
(defn numeric-op | |
"D-type General numeric op" | |
[vm [x y] f] | |
(memory-put vm :mem (:counter vm) (f (mem-read vm x) (mem-read vm y)))) | |
(defn phi | |
"D-type" | |
[vm [x y]] | |
(let [m (:mem vm)] | |
(trace 'Phi (format "%s ? %s : %s --> %s" (:status vm) (m x) (m y) (if (:status vm) (m x) (m y)))) | |
(memory-put vm :mem (:counter vm) | |
(if (:status vm) (m x) (m y))))) | |
(defn print-args | |
[vm op x y] | |
(format "%s %s // %s %s %s" x y (mem-read vm x) op (mem-read vm y))) | |
(defn add | |
"D-type Add instruction" | |
[vm [x y]] | |
(trace 'Add (print-args vm '+ x y)) | |
(numeric-op vm [x y] +)) | |
(defn sub | |
"D-type Sub instruction" | |
[vm [x y]] | |
(trace 'Sub (print-args vm '- x y)) | |
(numeric-op vm [x y] -)) | |
(defn mult | |
"D-type Multiply instruction" | |
[vm [x y]] | |
(trace 'Mult (print-args vm '* x y)) | |
(numeric-op vm [x y] *)) | |
(defn div | |
"D-type Divide" | |
[vm args] | |
(trace 'Div) | |
(numeric-op vm args (fn [x y] (if (zero? y) 0 (/ x y))))) | |
(defn noop | |
"S-type Noop instruction" | |
[vm args] | |
(trace 'Noop) | |
vm) | |
(defn copy | |
"S-Type: Copy instruction" | |
[vm [x]] | |
(trace 'Copy (format "%s // %s" x (mem-read vm x))) | |
(memory-put vm :mem (:counter vm) (mem-read vm x))) | |
(defn sqrt | |
"S-Type: Square root instruction: undefined for negative values" | |
[vm [x]] | |
(trace 'Sqrt) | |
(assert (not (neg? (mem-read vm x)))) | |
(memory-put vm :mem (:counter vm) (Math/sqrt (mem-read vm x)))) | |
(defn input | |
"S-Type: Set the memory from the inport" | |
[vm [x]] | |
(trace 'Input) | |
(memory-put vm :mem (:counter vm) (memory-read vm :inport x))) | |
(defn output | |
"Output instruction: Set the memory on the outport" | |
[vm [x y]] | |
(trace 'Output (format "%s %s // %s" x y (mem-read vm y))) | |
(memory-put vm :outport x (mem-read vm y))) | |
(defn cmpz | |
"Comparison function" | |
[vm [cmp y]] | |
(let [val (mem-read vm y) | |
status (cond ;; TODO replace this with functions so it becomes (apply cmp val) | |
(= cmp 'LTZ) (< val 0) | |
(= cmp 'LEZ) (<= val 0) | |
(= cmp 'EQZ) (zero? val) | |
(= cmp 'GEZ) (> val 0) | |
(= cmp 'GTZ) (>= val 0) | |
:else (assert false))] | |
(trace 'Cmpz (format "%s %s --> %s" cmp y status)) | |
(assoc vm :status status))) | |
(def d-type-instructions {1 add, 2 sub, 3 mult, 4 div, 5 output, 6 phi}) | |
(def s-type-instructions {0 noop, 1 cmpz, 2 sqrt, 3 copy, 4 input}) | |
(def comparison {0 'LTZ, 1 'LEZ, 2 'EQZ, 3 'GEZ, 4 'GTZ}) |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment