c97b74976098

--- a/src/wam/compile.lisp	Sun Apr 10 16:02:54 2016 +0000
+++ b/src/wam/compile.lisp	Sun Apr 10 17:43:04 2016 +0000
@@ -346,8 +346,7 @@
                (handle-argument register target))
               (`(:structure ,register ,functor ,arity)
                (handle-structure register functor arity))
-              (register (handle-register register)))
-            ))))
+              (register (handle-register register)))))))
 
 (defun compile-query-tokens (wam tokens functor arity store)
   (compile-tokens wam tokens store :query)
@@ -356,7 +355,9 @@
     (wam-ensure-functor-index wam (cons functor arity))))
 
 (defun compile-program-tokens (wam tokens functor arity store)
-  ; todo: add functor/arity into labels
+  ; todo: make this less ugly
+  (setf (wam-code-label wam (wam-ensure-functor-index wam (cons functor arity)))
+        (fill-pointer (wam-code wam)))
   (compile-tokens wam tokens store :program)
   (vector-push-extend +opcode-proceed+ store))
 

--- a/src/wam/dump.lisp	Sun Apr 10 16:02:54 2016 +0000
+++ b/src/wam/dump.lisp	Sun Apr 10 17:43:04 2016 +0000
@@ -161,6 +161,15 @@
 (defun dump-wam-functors (wam)
   (format t " FUNCTORS: ~S~%" (wam-functors wam)))
 
+(defun dump-labels (wam)
+  (format t "LABELS:~%~{  ~A -> ~4,'0X~^~%~}~%"
+          (loop :for functor-index
+                :being :the :hash-keys :of (wam-code-labels wam)
+                :using (hash-value address)
+                :nconc (list (pretty-functor functor-index
+                                             (wam-functors wam))
+                             address))))
+
 
 (defun dump-wam (wam from to highlight)
   (format t "     FAIL: ~A~%" (wam-fail wam))
@@ -172,6 +181,7 @@
   (format t "~%")
   (dump-heap wam from to highlight)
   (format t "~%")
+  (dump-labels wam)
   (dump-code wam))
 
 (defun dump-wam-full (wam)

--- a/src/wam/instructions.lisp	Sun Apr 10 16:02:54 2016 +0000
+++ b/src/wam/instructions.lisp	Sun Apr 10 17:43:04 2016 +0000
@@ -67,7 +67,6 @@
     (deref wam (cell-value (wam-heap-cell wam address)))
     address))
 
-
 (defun* bind! ((wam wam) (address-1 heap-index) (address-2 heap-index))
   (:returns :void)
   "Bind the unbound reference cell to the other.
@@ -90,7 +89,6 @@
     (t (error "At least one cell must be an unbound reference when binding.")))
   (values))
 
-
 (defun* fail! ((wam wam) (reason string))
   (:returns :void)
   "Mark a failure in the WAM."
@@ -159,16 +157,20 @@
 (defun* %put-variable ((wam wam)
                        (register register-index)
                        (argument register-index))
+  (:returns :void)
   (->> (push-unbound-reference! wam)
     (nth-value 1)
     (setf (wam-register wam register))
-    (setf (wam-register wam argument))))
+    (setf (wam-register wam argument)))
+  (values))
 
 (defun* %put-value ((wam wam)
                     (register register-index)
                     (argument register-index))
-  (setf (wam-register wam register)
-        (wam-register wam argument)))
+  (:returns :void)
+  (setf (wam-register wam argument)
+        (wam-register wam register))
+  (values))
 
 
 ;;;; Program Instructions
@@ -231,8 +233,9 @@
   (ecase (wam-mode wam)
     (:read (setf (wam-register wam register)
                  (wam-s wam)))
-    (:write (setf (wam-register wam register)
-                  (nth-value 1 (push-unbound-reference! wam)))))
+    (:write (->> (push-unbound-reference! wam)
+              (nth-value 1)
+              (setf (wam-register wam register)))))
   (incf (wam-s wam))
   (values))
 
@@ -240,12 +243,29 @@
   (:returns :void)
   (ecase (wam-mode wam)
     (:read (unify! wam
-                   (cell-value (wam-register wam register))
+                   (wam-register wam register)
                    (wam-s wam)))
-    (:write (wam-heap-push! wam (wam-register wam register))))
+    (:write (wam-heap-push! wam (wam-register-cell wam register))))
   (incf (wam-s wam))
   (values))
 
+(defun* %get-variable ((wam wam)
+                       (register register-index)
+                       (argument register-index))
+  (:returns :void)
+  (setf (wam-register wam register)
+        (wam-register wam argument))
+  (values))
+
+(defun* %get-value ((wam wam)
+                    (register register-index)
+                    (argument register-index))
+  (:returns :void)
+  (unify! wam
+          (wam-register wam register)
+          (wam-register wam argument))
+  (values))
+  
 
 ;;;; Running
 (defmacro instruction-call (wam instruction code-store pc number-of-arguments)
@@ -284,3 +304,4 @@
           (error "Fell off the end of the query code store!")))))
   (values))
 
+

--- a/src/wam/wam.lisp	Sun Apr 10 16:02:54 2016 +0000
+++ b/src/wam/wam.lisp	Sun Apr 10 17:43:04 2016 +0000
@@ -22,9 +22,13 @@
      :initform (make-array 64
                            :fill-pointer 0
                            :adjustable t
-                           :element-type 'functors)
+                           :element-type 'functor)
      :accessor wam-functors
      :documentation "The array of functors in this WAM.")
+   (code-labels
+     :initform (make-hash-table)
+     :accessor wam-code-labels
+     :documentation "The mapping of functor indices -> code store addresses.")
    (registers
      :reader wam-registers
      :initform (make-array +register-count+
@@ -148,6 +152,15 @@
       (wam-code-push-word! wam arg))))
 
 
+(defun* wam-code-label ((wam wam)
+                        (functor functor-index))
+  (:returns code-index)
+  (gethash functor (wam-code-labels wam)))
+
+(defun (setf wam-code-label) (new-value wam functor)
+  (setf (gethash functor (wam-code-labels wam)) new-value))
+
+
 ;;;; Registers
 ;;; WAM registers are implemented as an array of a fixed number of registers.
 ;;; A register contains the address of a cell in the heap.