--- a/src/make-utilities.lisp Sat Mar 26 22:53:28 2016 +0000
+++ b/src/make-utilities.lisp Sun Mar 27 18:32:37 2016 +0000
@@ -4,5 +4,7 @@
:utilities '(:define-constant
:set-equal
:curry
- :switch)
+ :switch
+ :ensure-boolean
+ )
:package "BONES.UTILS")
--- a/src/utils.lisp Sat Mar 26 22:53:28 2016 +0000
+++ b/src/utils.lisp Sun Mar 27 18:32:37 2016 +0000
@@ -2,7 +2,7 @@
;;;; See http://quickutil.org for details.
;;;; To regenerate:
-;;;; (qtlc:save-utils-as "utils.lisp" :utilities '(:DEFINE-CONSTANT :SET-EQUAL :CURRY :SWITCH) :ensure-package T :package "BONES.UTILS")
+;;;; (qtlc:save-utils-as "utils.lisp" :utilities '(:DEFINE-CONSTANT :SET-EQUAL :CURRY :SWITCH :ENSURE-BOOLEAN) :ensure-package T :package "BONES.UTILS")
(eval-when (:compile-toplevel :load-toplevel :execute)
(unless (find-package "BONES.UTILS")
@@ -17,7 +17,7 @@
:MAKE-GENSYM-LIST :ENSURE-FUNCTION
:CURRY :STRING-DESIGNATOR
:WITH-GENSYMS :EXTRACT-FUNCTION-NAME
- :SWITCH))))
+ :SWITCH :ENSURE-BOOLEAN))))
(defun %reevaluate-constant (name value test)
(if (not (boundp name))
@@ -205,7 +205,13 @@
"Like `switch`, but signals a continuable error if no key matches."
(generate-switch-body whole object clauses test key '(cerror "Return NIL from CSWITCH.")))
+
+ (defun ensure-boolean (x)
+ "Convert `x` into a Boolean value."
+ (and x t))
+
(eval-when (:compile-toplevel :load-toplevel :execute)
- (export '(define-constant set-equal curry switch eswitch cswitch)))
+ (export '(define-constant set-equal curry switch eswitch cswitch
+ ensure-boolean)))
;;;; END OF utils.lisp ;;;;
--- a/src/wam/cells.lisp Sat Mar 26 22:53:28 2016 +0000
+++ b/src/wam/cells.lisp Sun Mar 27 18:32:37 2016 +0000
@@ -97,13 +97,30 @@
(+tag-structure+
(format nil " ~D" (cell-value cell)))
(+tag-functor+
- (format nil "functor ~D/~D"
+ (format nil " functor ~D/~D"
(cell-functor-index cell)
(cell-functor-arity cell)))
(+tag-reference+
(format nil " ~D" (cell-value cell))))))
+(defun* cell-null-p ((cell heap-cell))
+ (:returns boolean)
+ (= (cell-type cell) +tag-null+))
+
+(defun* cell-reference-p ((cell heap-cell))
+ (:returns boolean)
+ (= (cell-type cell) +tag-reference+))
+
+(defun* cell-functor-p ((cell heap-cell))
+ (:returns boolean)
+ (= (cell-type cell) +tag-functor+))
+
+(defun* cell-structure-p ((cell heap-cell))
+ (:returns boolean)
+ (= (cell-type cell) +tag-structure+))
+
+
(defun* make-cell ((tag heap-cell-tag) (value heap-cell-value))
(:returns heap-cell)
(values
--- a/src/wam/dump.lisp Sat Mar 26 22:53:28 2016 +0000
+++ b/src/wam/dump.lisp Sun Mar 27 18:32:37 2016 +0000
@@ -15,7 +15,6 @@
(defun dump-heap (wam from to highlight)
;; This code is awful, sorry.
(let ((heap (wam-heap wam)))
- (format t "HEAP SIZE: ~A~%" (length heap))
(format t " +------+-----+--------------+----------------------------+~%")
(format t " | ADDR | TYP | VALUE | DEBUG |~%")
(format t " +------+-----+--------------+----------------------------+~%")
@@ -40,19 +39,24 @@
(defun dump-wam-registers (wam)
(format t "REGISTERS:~%")
+ (format t "~5@A ->~4@A~%" "S" (wam-s wam))
(loop :for i :from 0
:for reg :across (wam-registers wam)
- :do (format t "~5@A -> ~A~%"
+ :for contents = (wam-register-cell wam i)
+ :do (format t "~5@A ->~4@A ~A~%"
(format nil "X~D" i)
- (cell-aesthetic reg))))
+ reg
+ (cell-aesthetic contents))))
(defun dump-wam-functors (wam)
- (format t "FUNCTORS: ~S~%" (wam-functors wam)))
+ (format t " FUNCTORS: ~S~%" (wam-functors wam)))
(defun dump-wam (wam from to highlight)
+ (format t " FAIL: ~A~%" (wam-fail wam))
+ (format t " MODE: ~A~%" (wam-mode wam))
(dump-wam-functors wam)
- (format t "~%")
+ (format t "HEAP SIZE: ~A~%" (length (wam-heap wam)))
(dump-wam-registers wam)
(format t "~%")
(dump-heap wam from to highlight))
--- a/src/wam/instructions.lisp Sat Mar 26 22:53:28 2016 +0000
+++ b/src/wam/instructions.lisp Sun Mar 27 18:32:37 2016 +0000
@@ -1,30 +1,123 @@
(in-package #:bones.wam)
+;;;; Utilities
+(defun* push-unbound-reference! ((wam wam))
+ (:returns (values heap-cell heap-index))
+ "Push a new unbound reference cell onto the heap."
+ (wam-heap-push! wam (make-cell-reference (wam-heap-pointer wam))))
+
+(defun* push-new-structure! ((wam wam))
+ (:returns (values heap-cell heap-index))
+ "Push a new structure cell onto the heap.
+
+ The structure cell's value will point at the next address, so make sure you
+ push something there too!
+
+ "
+ (wam-heap-push! wam (make-cell-structure (1+ (wam-heap-pointer wam)))))
+
+(defun* push-new-functor! ((wam wam) (functor symbol) (arity arity))
+ (:returns (values heap-cell heap-index))
+ "Push a new functor cell onto the heap.
+
+ If the functor isn't already in the functor table it will be added.
+
+ "
+ (wam-heap-push! wam (make-cell-functor
+ (wam-ensure-functor-index wam functor)
+ arity)))
+
+
+(defun* bound-reference-p ((address heap-index) (cell heap-cell))
+ (:returns boolean)
+ "Return whether `cell` is a bound reference, assuming it lives at `address`."
+ (ensure-boolean
+ (and (cell-reference-p cell)
+ (not (= (cell-value cell) address)))))
+
+(defun* unbound-reference-p ((address heap-index) (cell heap-cell))
+ (:returns boolean)
+ "Return whether `cell` is an unbound reference, assuming it lives at `address`."
+ (ensure-boolean
+ (and (cell-reference-p cell)
+ (= (cell-value cell) address))))
+
+(defun* matching-functor-p ((wam wam)
+ (cell heap-cell)
+ (functor symbol)
+ (arity arity))
+ (:returns boolean)
+ "Return whether `cell` is a functor cell of `functor`/`arity`."
+ (ensure-boolean
+ (and (cell-functor-p cell)
+ (= arity (cell-functor-arity cell))
+ (eql functor
+ (wam-functor-lookup wam (cell-functor-index cell))))))
+
+
+(defun* deref ((wam wam) (address heap-index))
+ (:returns heap-index)
+ "Dereference the address in the WAM to its eventual destination.
+
+ If the address is a variable that's bound to something, that something will be
+ looked up (recursively) and the address of whatever it's ultimately bound to
+ will be returned.
+
+ "
+ (let ((cell (wam-heap-cell wam address)))
+ (if (bound-reference-p address cell)
+ (deref wam (cell-value cell))
+ address)))
+
+
+(defun* bind! ((wam wam) (address heap-index) (target heap-index))
+ "Bind the reference cell at `address` to `target`.
+
+ The reference cell must be unbound to begin with.
+ TODO: are we sure about this?
+
+ `target` doesn't necessarily need to exist yet.
+ TODO: this seems dangerous...
+
+ "
+ (assert (unbound-reference-p address
+ (wam-heap-cell wam address))
+ ()
+ "Cannot bind address ~D because it is not an unbound reference."
+ address)
+ (setf (wam-heap-cell wam address)
+ (make-cell-reference target)))
+
+(defun* fail! ((wam wam))
+ "Mark a failure in the WAM."
+ (setf (wam-fail wam) t))
+
+
+(defun* unify ((wam wam) (a1 heap-index) (a2 heap-index))
+ nil
+ )
+
+
;;;; Query Instructions
(defun* %put-structure ((wam wam)
(functor symbol)
(arity arity)
(register register-index))
(:returns :void)
- (let ((structure-cell (make-cell-structure (1+ (wam-heap-pointer wam))))
- (functor-cell (make-cell-functor
- (wam-ensure-functor-index wam functor)
- arity)))
- (wam-heap-push! wam structure-cell)
- (wam-heap-push! wam functor-cell)
- (setf (wam-register wam register) structure-cell))
+ (setf (wam-register wam register)
+ (nth-value 1 (push-new-structure! wam)))
+ (push-new-functor! wam functor arity)
(values))
(defun* %set-variable ((wam wam) (register register-index))
(:returns :void)
- (let ((cell (make-cell-reference (wam-heap-pointer wam))))
- (wam-heap-push! wam cell)
- (setf (wam-register wam register) cell))
+ (setf (wam-register wam register)
+ (nth-value 1 (push-unbound-reference! wam)))
(values))
(defun* %set-value ((wam wam) (register register-index))
(:returns :void)
- (wam-heap-push! wam (wam-register wam register))
+ (wam-heap-push! wam (wam-register-cell wam register))
(values))
@@ -34,13 +127,44 @@
(arity arity)
(register register-index))
(:returns :void)
+ (let* ((addr (deref wam (wam-register wam register)))
+ (cell (wam-heap-cell wam addr)))
+ (cond
+ ;; If the register points at a reference cell
+ ((cell-reference-p cell)
+ (bind! wam addr (wam-heap-pointer wam))
+ (push-new-structure! wam)
+ (push-new-functor! wam functor arity)
+ (setf (wam-mode wam) :write))
+ ;; If the register points at a structure cell
+ ((cell-structure-p cell)
+ (let* ((target-addr (cell-value cell))
+ (target (wam-heap-cell wam target-addr)))
+ (if (matching-functor-p wam target functor arity)
+ (progn
+ (setf (wam-s wam) (1+ target-addr))
+ (setf (wam-mode wam) :read))
+ (fail! wam))))
+ (t (fail! wam))))
(values))
(defun* %unify-variable ((wam wam) (register register-index))
(:returns :void)
+ (ecase (wam-mode wam)
+ (:read (setf (wam-register wam register)
+ (wam-s-cell wam)))
+ (:write (setf (wam-register wam register)
+ (nth-value 1 (push-unbound-reference! wam)))))
+ (incf (wam-s wam))
(values))
(defun* %unify-value ((wam wam) (register register-index))
(:returns :void)
+ (ecase (wam-mode wam)
+ (:read (unify wam
+ (cell-value (wam-register wam register))
+ (wam-s wam)))
+ (:write (wam-heap-push! wam (wam-register wam register))))
+ (incf (wam-s wam))
(values))
--- a/src/wam/wam.lisp Sat Mar 26 22:53:28 2016 +0000
+++ b/src/wam/wam.lisp Sun Mar 27 18:32:37 2016 +0000
@@ -1,9 +1,11 @@
(in-package #:bones.wam)
;;;; WAM
+(defparameter *wam-heap-size* 32)
+
(defclass wam ()
((heap
- :initform (make-array 32
+ :initform (make-array *wam-heap-size*
:initial-element (make-cell-null)
:element-type 'heap-cell)
:reader wam-heap
@@ -22,9 +24,26 @@
(registers
:reader wam-registers
:initform (make-array +register-count+
- :initial-element (make-cell-null)
- :element-type 'heap-cell)
- :documentation "An array of the X_i registers.")))
+ ;; Point at the last heap index by default, just to
+ ;; make it easier to read debug output.
+ :initial-element (1- *wam-heap-size*)
+ :element-type 'heap-index)
+ :documentation "An array of the X_i registers.")
+ (fail
+ :accessor wam-fail
+ :initform nil
+ :type boolean
+ :documentation "The failure register.")
+ (s
+ :accessor wam-s
+ :initform nil
+ :type (or null heap-index)
+ :documentation "The S register (address of next subterm to match).")
+ (mode
+ :accessor wam-mode
+ :initform nil
+ :type (or null (member :read :write))
+ :documentation "Current unification mode (:READ or :WRITE (or NIL)).")))
(defun make-wam ()
@@ -38,16 +57,16 @@
;;; because you can only index so many addresses with N bits.
(defun* wam-heap-push! ((wam wam) (cell heap-cell))
- (:returns heap-cell)
+ (:returns (values heap-cell heap-index))
"Push the cell onto the WAM heap and increment the heap pointer.
- Returns the cell.
+ Returns the cell and the address it was pushed to.
"
(with-slots (heap heap-pointer) wam
(setf (aref heap heap-pointer) cell)
(incf heap-pointer)
- cell))
+ (values cell (1- heap-pointer))))
(defun* wam-heap-cell ((wam wam) (address heap-index))
@@ -61,6 +80,7 @@
;;;; 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.
(defun* wam-register ((wam wam) (register register-index))
(:returns heap-cell)
@@ -70,6 +90,24 @@
(defun (setf wam-register) (new-value wam register)
(setf (aref (wam-registers wam) register) new-value))
+(defun* wam-register-cell ((wam wam) (register register-index))
+ (:returns heap-cell)
+ "Return the heap cell `register` is pointing at."
+ (->> register
+ (wam-register wam)
+ (wam-heap-cell wam)))
+
+(defun* wam-s-cell ((wam wam))
+ "Retrieve the cell the S register is pointing at.
+
+ If S is unbound, throws an error.
+
+ "
+ (let ((s (wam-s wam)))
+ (if (null s)
+ (error "Cannot dereference unbound S register.")
+ (wam-heap-cell wam s))))
+
;;;; Functors
;;; Functors are symbols stored in an adjustable array. Cells refer to