8a247663fec5

--- a/bones.asd	Sat Jul 16 18:23:34 2016 +0000
+++ b/bones.asd	Sat Jul 16 19:23:51 2016 +0000
@@ -8,12 +8,9 @@
   :license "MIT/X11"
   :version "0.0.1"
 
-  :depends-on (#:optima
-               #:trivial-types
+  :depends-on (#:trivial-types
                #:cl-arrows
-               #:policy-cond
-               #:fare-quasiquote-optima
-               #:fare-quasiquote-readtable)
+               #:policy-cond)
 
   :serial t
   :components ((:file "src/quickutils") ; quickutils package ordering crap

--- a/package.lisp	Sat Jul 16 18:23:34 2016 +0000
+++ b/package.lisp	Sat Jul 16 19:23:51 2016 +0000
@@ -64,7 +64,6 @@
 (defpackage #:bones.wam
   (:use
     #:cl
-    #:optima
     #:cl-arrows
     #:bones.circle
     #:bones.quickutils
@@ -104,9 +103,7 @@
 
     #:call
     #:?
-    #:!)
-  (:import-from #:optima
-    #:match))
+    #:!))
 
 (defpackage #:bones.paip
   (:use

--- a/src/wam/compiler/6-optimization.lisp	Sat Jul 16 18:23:34 2016 +0000
+++ b/src/wam/compiler/6-optimization.lisp	Sat Jul 16 19:23:51 2016 +0000
@@ -1,5 +1,4 @@
 (in-package #:bones.wam)
-(named-readtables:in-readtable :fare-quasiquote)
 
 ;;;; ,,--.     .                    .
 ;;;; |`, | ,-. |- . ,-,-. . ,_, ,-. |- . ,-. ,-.
@@ -52,27 +51,30 @@
     (circle-replace n `(:subterm-constant ,constant))
     (return (circle-backward-remove node))))
 
+
 (defun optimize-constants (instructions)
   ;; From the book and the erratum, there are four optimizations we can do for
   ;; constants (0-arity structures).
 
-  (loop :for node = (circle-forward instructions) :then (circle-forward node)
-        :while node
-        :for (opcode . arguments) = (circle-value node)
-        :do
-        (match (circle-value node)
-
-          (`(:put-structure ,functor 0 ,register)
-           (setf node
-                 (if (register-argument-p register)
-                   (optimize-put-constant node functor register)
-                   (optimize-subterm-constant-query node functor register))))
-
-          (`(:get-structure ,functor 0 ,register)
-           (setf node
-                 (if (register-argument-p register)
-                   (optimize-get-constant node functor register)
-                   (optimize-subterm-constant-program node functor register))))))
+  (flet ((optimize-put (node functor register)
+           (if (register-argument-p register)
+             (optimize-put-constant node functor register)
+             (optimize-subterm-constant-query node functor register)))
+         (optimize-get (node functor register)
+           (if (register-argument-p register)
+             (optimize-get-constant node functor register)
+             (optimize-subterm-constant-program node functor register))))
+    (loop
+      :for node = (circle-forward instructions) :then (circle-forward node)
+      :while node :do
+      (destructuring-bind (opcode . arguments) (circle-value node)
+        (when (member opcode '(:put-structure :get-structure))
+          (destructuring-bind (functor arity register) arguments
+            (when (zerop arity)
+              (setf node
+                    (case opcode
+                      (:put-structure (optimize-put node functor register))
+                      (:get-structure (optimize-get node functor register))))))))))
   instructions)
 
 

--- a/src/wam/compiler/7-rendering.lisp	Sat Jul 16 18:23:34 2016 +0000
+++ b/src/wam/compiler/7-rendering.lisp	Sat Jul 16 19:23:51 2016 +0000
@@ -102,10 +102,14 @@
         :with address = start
 
         ;; Render the next instruction
-        :for (opcode-designator . arguments) :in (circle-to-list instructions)
+        :for node = (circle-forward instructions)
+        :then (or (circle-forward node)
+                  (return instruction-count))
+
+        :for (opcode-designator . arguments) = (circle-value node)
         :for opcode = (render-opcode opcode-designator)
         :for size = (instruction-size opcode)
-        :summing size
+        :summing size :into instruction-count
 
         ;; Make sure we don't run past the end of our section.
         :when (>= (+ size address) limit)

--- a/test/run.lisp	Sat Jul 16 18:23:34 2016 +0000
+++ b/test/run.lisp	Sat Jul 16 19:23:51 2016 +0000
@@ -4,7 +4,8 @@
 
 
 (let ((*standard-output* (make-broadcast-stream))
-      (*error-output* (make-broadcast-stream)))
+      ; (*error-output* (make-broadcast-stream))
+      )
   (asdf:load-system 'bones :force t)
   (ql:quickload "bones-test"))