6138ec555cde

--- a/src/wam/cells.lisp	Fri Apr 01 19:16:23 2016 +0000
+++ b/src/wam/cells.lisp	Tue Apr 05 15:00:28 2016 +0000
@@ -55,14 +55,7 @@
 
 (defun* cell-functor-index ((cell heap-cell))
   (:returns functor-index)
-  (ash (cell-value cell)
-       (- +functor-arity-width+)))
-
-(defun* cell-functor-arity ((cell heap-cell))
-  (:returns arity)
-  (values
-    (logand (cell-value cell)
-            +functor-arity-bitmask+)))
+  (cell-value cell))
 
 
 (defun* cell-aesthetic ((cell heap-cell))
@@ -74,9 +67,8 @@
             (+tag-structure+
               (format nil " ~D" (cell-value cell)))
             (+tag-functor+
-              (format nil " functor ~D/~D"
-                      (cell-functor-index cell)
-                      (cell-functor-arity cell)))
+              (format nil " functor ~D"
+                      (cell-functor-index cell)))
             (+tag-reference+
               (format nil " ~D" (cell-value cell))))))
 
@@ -116,12 +108,8 @@
   (:returns heap-cell)
   (make-cell +tag-reference+ value))
 
-(defun* make-cell-functor ((functor-index functor-index)
-                           (arity arity))
+(defun* make-cell-functor ((functor-index functor-index))
   (:returns heap-cell)
-  (make-cell
-    +tag-functor+
-    (logior (ash functor-index +functor-arity-width+)
-            arity)))
+  (make-cell +tag-functor+ functor-index))
 
 

--- a/src/wam/compile.lisp	Fri Apr 01 19:16:23 2016 +0000
+++ b/src/wam/compile.lisp	Tue Apr 05 15:00:28 2016 +0000
@@ -296,7 +296,7 @@
 ;;;   (#'%set-value 1)
 ;;;   (#'%set-value 2)
 
-(defun generate-actions (tokens store mode)
+(defun generate-actions (wam tokens store mode)
   "Generate a series of machine instructions from a stream of tokens."
   (let ((seen (list)))
     (flet ((handle-argument (register target)
@@ -319,7 +319,9 @@
                                    (:program +opcode-get-structure+)
                                    (:query +opcode-put-structure+))
                                  store)
-             (vector-push-extend arity store) ; todo: add functor
+             (vector-push-extend
+               (wam-ensure-functor-index wam (cons functor arity))
+               store)
              (vector-push-extend register store))
            (handle-register (register)
              (if (member register seen)
@@ -344,23 +346,29 @@
                (handle-structure register functor arity))
               (register (handle-register register)))))))
 
-(defun generate-query-actions (tokens store)
-  (generate-actions tokens store :query))
+(defun generate-query-actions (wam tokens store)
+  (generate-actions wam tokens store :query))
 
-(defun generate-program-actions (tokens store)
-  (generate-actions tokens store :program))
+(defun generate-program-actions (wam tokens store)
+  (generate-actions wam tokens store :program))
 
 
 ;;;; UI
-(defun compile-query-term (term)
+(defun compile-query-term (wam term)
   "Parse a Lisp query term into a series of WAM machine instructions."
-  (-> term
+  (let ((code (make-array 64
+                          :fill-pointer 0
+                          :adjustable t
+                          :element-type 'code-word)))
+    (-<>> term
       parse-term
-      flatten-query
-      tokenize-assignments
-      generate-query-actions))
+      (multiple-value-call #'inline-structure-argument-assignments)
+      (multiple-value-call #'flatten-query)
+      (multiple-value-call #'tokenize-assignments)
+      (generate-query-actions wam <> code))
+    code))
 
-(defun compile-program-term (term)
+(defun compile-program-term (wam term)
   "Parse a Lisp program term into a series of WAM machine instructions."
   (-> term
       parse-term

--- a/src/wam/dump.lisp	Fri Apr 01 19:16:23 2016 +0000
+++ b/src/wam/dump.lisp	Tue Apr 05 15:00:28 2016 +0000
@@ -47,17 +47,52 @@
     (values)))
 
 
-(defun instruction-aesthetic (instruction)
-  (format nil "~A~{ ~4,'0X~}"
-          (opcode-short-name (aref instruction 0))
-          (rest (coerce instruction 'list))))
+(defun pretty-functor (functor-index functor-list)
+  (when functor-list
+    (destructuring-bind (symbol . arity)
+        (elt functor-list functor-index)
+      (format nil "~A/~D" symbol arity))))
+
+(defun pretty-arguments (arguments)
+  (format nil "~{ ~4,'0X~}" arguments))
+
+(defgeneric instruction-details (opcode arguments functor-list))
+
+(defmethod instruction-details ((opcode t) arguments functor-list)
+  (format nil "~A~A"
+          (opcode-short-name opcode)
+          (pretty-arguments arguments)))
 
-(defun dump-code-store (code-store &optional (from 0) (to (length code-store)))
+(defmethod instruction-details ((opcode (eql +opcode-get-structure+)) arguments functor-list)
+  (format nil "GETS~A ; ~A"
+          (pretty-arguments arguments)
+          (pretty-functor (first arguments) functor-list)))
+
+(defmethod instruction-details ((opcode (eql +opcode-put-structure+)) arguments functor-list)
+  (format nil "PUTS~A ; ~A"
+          (pretty-arguments arguments)
+          (pretty-functor (first arguments) functor-list)))
+
+
+; (defmethod instruction-details ((opcode (eql +opcode-set-variable+)) arguments functor-list))
+; (defmethod instruction-details ((opcode (eql +opcode-set-value+)) arguments functor-list))
+; (defmethod instruction-details ((opcode (eql +opcode-put-variable+)) arguments functor-list))
+; (defmethod instruction-details ((opcode (eql +opcode-put-value+)) arguments functor-list))
+
+; (defmethod instruction-details ((opcode (eql +opcode-call+)) arguments functor-list))
+; (defmethod instruction-details ((opcode (eql +opcode-proceed+)) arguments functor-list))
+
+(defun dump-code-store (code-store &optional
+                                   (from 0)
+                                   (to (length code-store))
+                                   functor-list)
   (let ((addr from))
     (while (< addr to)
       (format t "; ~4,'0X: " addr)
       (let ((instruction (retrieve-instruction code-store addr)))
-        (format t "~A~%" (instruction-aesthetic instruction))
+        (format t "~A~%" (instruction-details (aref instruction 0)
+                                              (rest (coerce instruction 'list))
+                                              functor-list))
         (incf addr (length instruction))))))
 
 (defun dump-code (wam &optional (from 0) (to (length (wam-code wam))))

--- a/src/wam/types.lisp	Fri Apr 01 19:16:23 2016 +0000
+++ b/src/wam/types.lisp	Tue Apr 05 15:00:28 2016 +0000
@@ -23,6 +23,9 @@
 (deftype arity ()
   `(integer 0 ,+maximum-arity+))
 
+(deftype functor ()
+  '(cons symbol arity))
+
 
 (deftype code-word ()
   `(unsigned-byte ,+code-word-size+))

--- a/src/wam/wam.lisp	Fri Apr 01 19:16:23 2016 +0000
+++ b/src/wam/wam.lisp	Tue Apr 05 15:00:28 2016 +0000
@@ -19,12 +19,12 @@
      :reader wam-code
      :documentation "The code store.")
    (functors
-     :initform (make-array 16
+     :initform (make-array 64
                            :fill-pointer 0
                            :adjustable t
-                           :element-type 'symbol)
+                           :element-type 'functors)
      :accessor wam-functors
-     :documentation "The array of functor symbols in this WAM.")
+     :documentation "The array of functors in this WAM.")
    (registers
      :reader wam-registers
      :initform (make-array +register-count+
@@ -180,13 +180,10 @@
 
 
 ;;;; Functors
-;;; Functors are symbols stored in an adjustable array.  Cells refer to
-;;; a functor using the functor's address in this array.
-;;;
-;;; TODO: Limit the number of functors based on the number of addressable
-;;; functors in the functor cell index bits.
+;;; Functors are stored in an adjustable array.  Cells refer to a functor using
+;;; the functor's address in this array.
 
-(defun* wam-ensure-functor-index ((wam wam) (functor symbol))
+(defun* wam-ensure-functor-index ((wam wam) (functor functor))
   (:returns functor-index)
   "Return the index of the functor in the WAM's functor table.
 
@@ -194,7 +191,7 @@
 
   "
   (with-slots (functors) wam
-    (or (position functor functors)
+    (or (position functor functors :test #'equal)
         (vector-push-extend functor functors))))
 
 (defun* wam-functor-lookup ((wam wam) (functor-index functor-index))