Add testing infrastructure and some rudimentary tests

- Add a compiler mode to dump all registers at the end,
  rather than loop forever (by providing a custom epilog,
  borrowed from http://www.fysnet.net/yourhelp.htm).
- Extend the assembler to be able to assemble that epilog
  (some opcodes were missing).
- Add a compiler driver that:
  - compiles and assembles the program to DOS .COM as usual;
  - copies the binary and the bundled CAPTURE.COM (from
    http://www.pc-tools.net/dos/dosutils/) to the same
    directory;
  - runs them with DOSBox via a generated batch file;
  - parses the resulting textual screen dump to get the
    CPU register values.
- Add some tests that compile an expression and check AX
  for the expected result.
- Update README.md to cater for licenses of bundled
  assembly code that is not mine.
- Move some code around.

Author: nathell

README.md

@@ -22,6 +22,10 @@ In the REPL:
 
 # License
 
+Unless otherwise noted, code in this repository is copyright by
+Daniel Janus and released under the MIT license:
+
+```
 Copyright 2012–2021 Daniel Janus
 
 Permission is hereby granted, free of charge, to any person obtaining
@@ -42,6 +46,26 @@ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
 LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
 OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
 WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+```
+
+The file `resources/capture.com` comes from the DOS Utilities Collection as obtained
+from http://www.pc-tools.net/dos/dosutils/, is copyright by Jem Berkes, and carries the
+following copyright notice:
+
+```
+You may use and share the programs in this freeware package. However,
+remember that YOU MAY NOT MODIFY THESE PROGRAMS IN ANY WAY. They are
+NOT PUBLIC DOMAIN, but rather COPYRIGHTED FREEWARE.
+
+I, the author, take NO RESPONSIBILITY for any damage that may result
+from using any of these programs.
+
+Jem Berkes <jberkes@pc-tools.net>
+```
+
+The assembly code in `register-dump` is a s-expression version of a snippet
+that comes from http://www.fysnet.net/yourhelp.htm and is copyright by
+Forever Young Software.
 
  [1]: https://blog.danieljanus.pl/2012/05/14/lithium/
  [2]: http://scheme2006.cs.uchicago.edu/11-ghuloum.pdf

resources/capture.com

@@ -70,17 +70,27 @@
       [:xor rm16 reg16]   [0x31 :r]
       [:push reg16]       [[:r+ 0x50]]
       [:pop reg16]        [[:r+ 0x58]]
+      [:push :cs]         [0x0e]
+      [:pushf]            [0x9c]
+      [:pusha]            [0x60]
       [:stosb]            [0xaa]
+      [:stosw]            [0xab]
+      [:movsw]            [0xa5]
+      [:rol rm16 imm8]    [0xc1 :0 :ib]
+      [:daa]              [0x27]
       [:ret]              [0xc3]
       [:cli]              [0xfa]
       [:inc reg16]        [[:r+ 0x40]]
       [:inc rm8]          [0xfe :0]
+      [:dec reg16]        [[:r+ 0x48]]
+      [:dec rm8]          [0xfe :1]
       [:cmp :al imm8]     [0x3c :ib]
       [:cmp :ax imm16]    [0x3d :iw]
       [:cmp rm8 imm8]     [0x80 :7 :ib]
       [:cmp rm16 imm16]   [0x81 :7 :iw]
       [:cmp reg8 rm8]     [0x3a :r]
       [:cmp reg16 rm16]   [0x3b :r]
+      [:adc :al imm8]     [0x14 :ib]
       [:add rm8 reg8]     [0x00 :r]
       [:add rm16 reg16]   [0x01 :r]
       [:add reg8 rm8]     [0x02 :r]
@@ -197,10 +207,14 @@
        [(+ (second byte-desc) (-> instr (extract-cc instr-template) +condition-codes+))])))
 
 (defn assemble-instruction [instr]
-  (let [[template parts] (find-template instr)]
-    (when-not template (throw (Exception. (str "Could not assemble instruction: " (pr-str instr)))))
-    (let [assembled-parts (map (partial parse-byte instr template) parts)]
-      (apply concat assembled-parts))))
+  (cond
+    (= (first instr) 'string) (map int (second instr))
+    (= (first instr) 'bytes) (second instr)
+    :otherwise
+    (let [[template parts] (find-template instr)]
+      (when-not template (throw (Exception. (str "Could not assemble instruction: " (pr-str instr)))))
+      (let [assembled-parts (map (partial parse-byte instr template) parts)]
+        (apply concat assembled-parts)))))
 
 ;; This is the value added to absolute addresses of labels, telling
 ;; the assembler where the code starts from. Defaults to 0x100 for
@@ -233,18 +247,7 @@
                 cnt (count assembled)]
             (recur (next prog) (into code assembled) (+ pc cnt) labels)))))))
 
-(defn hexdump [prog]
-  (string/join " " (map #(format "%02x" %) (asm prog))))
-
-(defn assemble-file [prog out]
-  (let [assembled (asm (if (string? prog) (read-string (str "[" (slurp prog) "]")) prog))
-        byte-arr  (into-array Byte/TYPE (map #(byte (if (>= % 128) (- % 256) %)) assembled))]
-    (with-open [f (java.io.FileOutputStream. out)]
-      (.write f (into-array Byte/TYPE (map #(byte (if (>= % 128) (- % 256) %)) assembled)))
-      nil)))
-
-(defn run-program! [prog]
-  (let [filename "/tmp/a.com"]
-    (assemble-file prog filename)
-    (sh "dosbox" filename)
-    nil))
+(defn assemble [prog]
+  (asm (if (string? prog)
+         (read-string (str "[" (slurp prog) "]"))
+         prog)))

src/lithium/assembler.clj

@@ -4,14 +4,59 @@
             [lithium.compiler.code :refer [codeseq compile-expr genkey]]
             [lithium.compiler.primitives :as primitives]
             [lithium.compiler.repr :as repr]
+            [lithium.driver :as driver]
             [lithium.utils :refer [read-all]]))
 
-(def prolog [['cli]
-             ['mov :bp :sp]
-             ['mov :si :heap-start]
-             ['add :si 7]
-             ['and :si 0xfff8]])
-(def epilog [:forever ['jmp :forever] :heap-start])
+(def prolog
+  [['cli]
+   ['mov :bp :sp]
+   ['mov :si :heap-start]
+   ['add :si 7]
+   ['and :si 0xfff8]])
+
+(def endless-loop-epilog
+  [:forever
+   ['jmp :forever]])
+
+(def register-dump
+  ;; taken from http://www.fysnet.net/yourhelp.htm
+  [['pushf]
+   ['pusha]
+   ['push :cs]
+   ['mov :di :buff]
+   ['mov :si :msg1]
+   ['mov :cx 10]
+   :loop1
+   ['movsw]
+   ['mov :al (int \=)]
+   ['stosb]
+   ['pop :ax]
+   ['mov :bx 4]
+   :ploop
+   ['rol :ax 4]
+   ['push :ax]
+   ['and :al 0x0f]
+   ['daa]
+   ['add :al 0xf0]
+   ['adc :al 0x40]
+   ['stosb]
+   ['pop :ax]
+   ['dec :bx]
+   ['jnz :ploop]
+   ['mov :ax 0x0d0a]
+   ['stosw]
+   ['loop :loop1]
+   ['mov :al 0x24]
+   ['stosb]
+   ['mov :dx :buff]
+   ['mov :ah 9]
+   ['int 0x21]
+   ['mov :ah 0x4c]
+   ['int 0x21]
+   :msg1
+   ['string "CSDISIBPSPBXDXCXAXFL"]
+   :buff
+   ['bytes (repeat 100 0)]])
 
 (defn primcall? [x]
   (or (list? x) (seq? x)))
@@ -224,15 +269,17 @@
    sexps))
 
 (defn compile-program
-  [sexps]
+  [prog & [{:keys [epilog]
+            :or {epilog endless-loop-epilog}}]]
   (concat prolog
-          (:code (compile-program* sexps))
-          epilog))
-
-(defn compile-file
-  [f]
-  (compile-program (read-all f)))
+          (:code (compile-program* (read-all prog)))
+          epilog
+          [:heap-start]))
 
 (defn compile-and-run!
-  [f]
-  (assembler/run-program! (compile-file f)))
+  ([f] (compile-and-run! f true))
+  ([f wait?]
+   (-> f
+       (compile-program {:epilog (if wait? endless-loop-epilog register-dump)})
+       assembler/assemble
+       (driver/run-program! wait?))))

src/lithium/compiler.clj

@@ -0,0 +1,42 @@
+(ns lithium.driver
+  (:require [clojure.java.io :as io]
+            [clojure.java.shell :refer [sh]]
+            [clojure.string :as string]))
+
+(defn run-and-wait! [prog]
+  (let [binary "/tmp/runwait.com"]
+    (with-open [f (java.io.FileOutputStream. binary)]
+      (.write f (byte-array prog))
+      (sh "dosbox" binary)
+      nil)))
+
+(defn parse-registers [str]
+  (->> (string/split str #"\r\n")
+       (map string/trim)
+       (filter seq)
+       (map (fn [s]
+              (let [[reg val] (string/split s #"=")]
+                [(keyword (string/lower-case reg))
+                 (Long/parseLong val 16)])))
+       (into {})))
+
+(defn run-and-capture-registers! [prog]
+  (let [tmpdir "/tmp"
+        binary (str tmpdir "/runcapt.com")
+        batch (str tmpdir "/run.bat")
+        screen-grab (str tmpdir "/TEXT.VID")]
+    (when (.exists (io/file screen-grab))
+      (io/delete-file screen-grab))
+    (with-open [f (java.io.FileOutputStream. binary)]
+      (.write f (byte-array prog)))
+    (with-open [in (io/input-stream (io/resource "capture.com"))]
+      (io/copy in (io/file (str tmpdir "/capture.com"))))
+    (spit batch "@cls\n@runcapt.com\n@capture.com t\n@exit\n")
+    (sh "dosbox" batch :env {"SDL_VIDEODRIVER" "dummy"})
+    (parse-registers (slurp screen-grab))))
+
+(defn run-program! [prog wait?]
+  ((if wait? run-and-wait! run-and-capture-registers!) prog))
+
+(defn hexdump [bytes]
+  (string/join " " (map #(format "%02x" %) bytes)))

src/lithium/driver.clj

@@ -4,6 +4,8 @@
 
 (defn read-all
   [input]
-  (with-open [f (java.io.PushbackReader. (io/reader input))]
-    (let [eof (Object.)]
-      (doall (take-while #(not= % eof) (repeatedly #(read f false eof)))))))
+  (if (or (string? input) (instance? java.io.File input))
+    (with-open [f (java.io.PushbackReader. (io/reader input))]
+      (let [eof (Object.)]
+        (doall (take-while #(not= % eof) (repeatedly #(read f false eof))))))
+    input))

src/lithium/utils.clj

@@ -0,0 +1,18 @@
+(ns lithium.compiler-test
+  (:require [lithium.compiler :as compiler]
+            [lithium.compiler.repr :as repr]
+            [clojure.test :refer [deftest are]]))
+
+(deftest test-compiler
+  (are [expr expected-result] (let [{:keys [ax]} (compiler/compile-and-run! [expr] false)]
+                                (= ax (repr/immediate expected-result)))
+    '(+ 3 4) 7
+    '(< 10 15) true
+    '(if true 3 4) 3
+    '(if (< 15 10) 3 4) 4
+    '(let [x 2 y (+ x 3)]
+       (+ x y)) 7
+    '(let [x 2
+           f (fn [y]
+               (+ x y))]
+       (f 3)) 5))