--- a/.lispwords Thu Jun 02 10:36:29 2016 +0000
+++ b/.lispwords Thu Jun 02 13:42:58 2016 +0000
@@ -2,3 +2,4 @@
(1 repeat)
(2 define-instruction define-instructions)
(1 with-database)
+(3 with-cell)
--- a/examples/ggp-wam.lisp Thu Jun 02 10:36:29 2016 +0000
+++ b/examples/ggp-wam.lisp Thu Jun 02 13:42:58 2016 +0000
@@ -3,8 +3,8 @@
(defparameter *d* (make-database))
(with-database *d*
- (rules ((member :thing (cons :thing :rest)))
- ((member :thing (cons :other :rest))
+ (rules ((member :thing '(:thing . :rest)))
+ ((member :thing '(:other . :rest))
(member :thing :rest)))
(rule (true :state :thing)
@@ -173,13 +173,13 @@
(defun extract (key results)
(mapcar (lambda (result) (getf result key)) results))
-(defun to-fake-list (l)
+(defun to-prolog-list (l)
(if (null l)
- 'nil
- `(cons ,(car l) ,(to-fake-list (cdr l)))))
+ nil
+ (list 'quote l)))
(defun initial-state ()
- (to-fake-list
+ (to-prolog-list
(with-database *d*
(extract :what (return-all (init :what))))))
@@ -205,13 +205,13 @@
(perform-return `((goal ,state :role :goal)) :all)))
(defun next-state (current-state move)
- (let ((does (to-fake-list `((does
- ,(getf move :role)
- ,(getf move :move))))))
+ (let ((does `('(does
+ ,(getf move :role)
+ ,(getf move :move)))))
(with-database *d*
- (to-fake-list
+ (to-prolog-list
(extract :what
- (perform-return `((next ,current-state ,does :what)) :all))))))
+ (perform-return `((next ,current-state ,does :what)) :all))))))
--- a/src/make-quickutils.lisp Thu Jun 02 10:36:29 2016 +0000
+++ b/src/make-quickutils.lisp Thu Jun 02 13:42:58 2016 +0000
@@ -12,6 +12,7 @@
:tree-member-p
:tree-collect
:with-gensyms
+ :once-only
:zip
:alist-to-hash-table
:map-tree
--- a/src/quickutils.lisp Thu Jun 02 10:36:29 2016 +0000
+++ b/src/quickutils.lisp Thu Jun 02 13:42:58 2016 +0000
@@ -2,7 +2,7 @@
;;;; See http://quickutil.org for details.
;;;; To regenerate:
-;;;; (qtlc:save-utils-as "quickutils.lisp" :utilities '(:DEFINE-CONSTANT :SET-EQUAL :CURRY :SWITCH :ENSURE-BOOLEAN :WHILE :UNTIL :TREE-MEMBER-P :TREE-COLLECT :WITH-GENSYMS :ZIP :ALIST-TO-HASH-TABLE :MAP-TREE :WEAVE :RANGE :ALIST-PLIST) :ensure-package T :package "BONES.QUICKUTILS")
+;;;; (qtlc:save-utils-as "quickutils.lisp" :utilities '(:DEFINE-CONSTANT :SET-EQUAL :CURRY :SWITCH :ENSURE-BOOLEAN :WHILE :UNTIL :TREE-MEMBER-P :TREE-COLLECT :WITH-GENSYMS :ONCE-ONLY :ZIP :ALIST-TO-HASH-TABLE :MAP-TREE :WEAVE :RANGE :ALIST-PLIST) :ensure-package T :package "BONES.QUICKUTILS")
(eval-when (:compile-toplevel :load-toplevel :execute)
(unless (find-package "BONES.QUICKUTILS")
@@ -19,9 +19,9 @@
:WITH-GENSYMS :EXTRACT-FUNCTION-NAME
:SWITCH :ENSURE-BOOLEAN :UNTIL :WHILE
:TREE-MEMBER-P :TREE-COLLECT
- :TRANSPOSE :ZIP :ALIST-TO-HASH-TABLE
- :MAP-TREE :WEAVE :RANGE :SAFE-ENDP
- :ALIST-PLIST))))
+ :ONCE-ONLY :TRANSPOSE :ZIP
+ :ALIST-TO-HASH-TABLE :MAP-TREE :WEAVE
+ :RANGE :SAFE-ENDP :ALIST-PLIST))))
(defun %reevaluate-constant (name value test)
(if (not (boundp name))
@@ -257,6 +257,45 @@
:append (tree-collect predicate item)))))
+ (defmacro once-only (specs &body forms)
+ "Evaluates `forms` with symbols specified in `specs` rebound to temporary
+variables, ensuring that each initform is evaluated only once.
+
+Each of `specs` must either be a symbol naming the variable to be rebound, or of
+the form:
+
+ (symbol initform)
+
+Bare symbols in `specs` are equivalent to
+
+ (symbol symbol)
+
+Example:
+
+ (defmacro cons1 (x) (once-only (x) `(cons ,x ,x)))
+ (let ((y 0)) (cons1 (incf y))) => (1 . 1)"
+ (let ((gensyms (make-gensym-list (length specs) "ONCE-ONLY"))
+ (names-and-forms (mapcar (lambda (spec)
+ (etypecase spec
+ (list
+ (destructuring-bind (name form) spec
+ (cons name form)))
+ (symbol
+ (cons spec spec))))
+ specs)))
+ ;; bind in user-macro
+ `(let ,(mapcar (lambda (g n) (list g `(gensym ,(string (car n)))))
+ gensyms names-and-forms)
+ ;; bind in final expansion
+ `(let (,,@(mapcar (lambda (g n)
+ ``(,,g ,,(cdr n)))
+ gensyms names-and-forms))
+ ;; bind in user-macro
+ ,(let ,(mapcar (lambda (n g) (list (car n) g))
+ names-and-forms gensyms)
+ ,@forms)))))
+
+
(defun transpose (lists)
"Analog to matrix transpose for a list of lists given by `lists`."
(apply #'mapcar #'list lists))
@@ -330,7 +369,7 @@
(eval-when (:compile-toplevel :load-toplevel :execute)
(export '(define-constant set-equal curry switch eswitch cswitch
ensure-boolean while until tree-member-p tree-collect with-gensyms
- with-unique-names zip alist-to-hash-table map-tree weave range
- alist-plist plist-alist)))
+ with-unique-names once-only zip alist-to-hash-table map-tree weave
+ range alist-plist plist-alist)))
;;;; END OF quickutils.lisp ;;;;
--- a/src/wam/bytecode.lisp Thu Jun 02 10:36:29 2016 +0000
+++ b/src/wam/bytecode.lisp Thu Jun 02 13:42:58 2016 +0000
@@ -1,6 +1,7 @@
(in-package #:bones.wam)
;;;; Opcodes
+(declaim (inline instruction-size))
(defun* instruction-size ((opcode opcode))
(:returns (integer 1 3))
"Return the size of an instruction for the given opcode.
@@ -11,7 +12,7 @@
(eswitch (opcode)
(+opcode-noop+ 1)
- (+opcode-get-structure-local+ 3)
+ (+opcode-get-structure+ 3)
(+opcode-unify-variable-local+ 2)
(+opcode-unify-variable-stack+ 2)
(+opcode-unify-value-local+ 2)
@@ -21,7 +22,7 @@
(+opcode-get-value-local+ 3)
(+opcode-get-value-stack+ 3)
- (+opcode-put-structure-local+ 3)
+ (+opcode-put-structure+ 3)
(+opcode-set-variable-local+ 2)
(+opcode-set-variable-stack+ 2)
(+opcode-set-value-local+ 2)
@@ -43,14 +44,17 @@
(+opcode-get-constant+ 3)
(+opcode-set-constant+ 2)
(+opcode-put-constant+ 3)
- (+opcode-unify-constant+ 2)))
+ (+opcode-unify-constant+ 2)
+
+ (+opcode-get-list+ 2)
+ (+opcode-put-list+ 2)))
(defun* opcode-name ((opcode opcode))
(:returns string)
(eswitch (opcode)
(+opcode-noop+ "NOOP")
- (+opcode-get-structure-local+ "GET-STRUCTURE")
+ (+opcode-get-structure+ "GET-STRUCTURE")
(+opcode-unify-variable-local+ "UNIFY-VARIABLE")
(+opcode-unify-variable-stack+ "UNIFY-VARIABLE")
(+opcode-unify-value-local+ "UNIFY-VALUE")
@@ -60,7 +64,7 @@
(+opcode-get-value-local+ "GET-VALUE")
(+opcode-get-value-stack+ "GET-VALUE")
- (+opcode-put-structure-local+ "PUT-STRUCTURE")
+ (+opcode-put-structure+ "PUT-STRUCTURE")
(+opcode-set-variable-local+ "SET-VARIABLE")
(+opcode-set-variable-stack+ "SET-VARIABLE")
(+opcode-set-value-local+ "SET-VALUE")
@@ -82,14 +86,17 @@
(+opcode-get-constant+ "GET-CONSTANT")
(+opcode-set-constant+ "SET-CONSTANT")
(+opcode-put-constant+ "PUT-CONSTANT")
- (+opcode-unify-constant+ "UNIFY-CONSTANT")))
+ (+opcode-unify-constant+ "UNIFY-CONSTANT")
+
+ (+opcode-get-list+ "GET-LIST")
+ (+opcode-put-list+ "PUT-LIST")))
(defun* opcode-short-name ((opcode opcode))
(:returns string)
(eswitch (opcode)
(+opcode-noop+ "NOOP")
- (+opcode-get-structure-local+ "GETS")
+ (+opcode-get-structure+ "GETS")
(+opcode-unify-variable-local+ "UVAR")
(+opcode-unify-variable-stack+ "UVAR")
(+opcode-unify-value-local+ "UVLU")
@@ -99,7 +106,7 @@
(+opcode-get-value-local+ "GVLU")
(+opcode-get-value-stack+ "GVLU")
- (+opcode-put-structure-local+ "PUTS")
+ (+opcode-put-structure+ "PUTS")
(+opcode-set-variable-local+ "SVAR")
(+opcode-set-variable-stack+ "SVAR")
(+opcode-set-value-local+ "SVLU")
@@ -121,5 +128,8 @@
(+opcode-get-constant+ "GCON")
(+opcode-set-constant+ "SCON")
(+opcode-put-constant+ "PCON")
- (+opcode-unify-constant+ "UCON")))
+ (+opcode-unify-constant+ "UCON")
+ (+opcode-get-list+ "GLST")
+ (+opcode-put-list+ "PLST")))
+
--- a/src/wam/cells.lisp Thu Jun 02 10:36:29 2016 +0000
+++ b/src/wam/cells.lisp Thu Jun 02 13:42:58 2016 +0000
@@ -67,7 +67,8 @@
cell-reference-p
cell-functor-p
cell-structure-p
- cell-constant-p))
+ cell-constant-p
+ cell-list-p))
(defun* cell-null-p ((cell cell))
(:returns boolean)
(= (cell-type cell) +tag-null+))
@@ -88,13 +89,18 @@
(:returns boolean)
(= (cell-type cell) +tag-constant+))
+(defun* cell-list-p ((cell cell))
+ (:returns boolean)
+ (= (cell-type cell) +tag-list+))
+
(declaim (inline make-cell
make-cell-null
make-cell-structure
make-cell-reference
make-cell-functor
- make-cell-constant))
+ make-cell-constant
+ make-cell-list))
(defun* make-cell ((tag cell-tag) (value cell-value))
(:returns cell)
(values
@@ -121,3 +127,8 @@
(:returns cell)
(make-cell +tag-constant+ functor-index))
+(defun* make-cell-list ((value cell-value))
+ (:returns cell)
+ (make-cell +tag-list+ value))
+
+
--- a/src/wam/compiler.lisp Thu Jun 02 10:36:29 2016 +0000
+++ b/src/wam/compiler.lisp Thu Jun 02 13:42:58 2016 +0000
@@ -1,6 +1,9 @@
(in-package #:bones.wam)
(named-readtables:in-readtable :fare-quasiquote)
+;; TODO: Thoroughly document the data formats between each phase.
+;; TODO: actually just rewrite this hole fuckin thing.
+
;;;; Registers
(deftype register-type ()
'(member :argument :local :permanent))
@@ -87,6 +90,13 @@
(:returns boolean)
(keywordp term))
+(defun* prolog-list-p (term)
+ (:returns boolean)
+ ;; TODO: is this how we wanna do this?
+ (and (consp term)
+ (eql 'quote (car term))
+ (consp (cdr term))))
+
(defun* variable-assignment-p ((assignment register-assignment))
"Return whether the register assigment is a simple variable assignment.
@@ -122,7 +132,8 @@
(defun* structure-assignment-p ((assignment register-assignment))
(:returns boolean)
"Return whether the given assignment pair is a structure assignment."
- (listp (cdr assignment)))
+ (and (listp (cdr assignment))
+ (eql (cadr assignment) :structure)))
(defun* structure-register-p ((register register)
(assignments register-assignment-list))
@@ -131,6 +142,19 @@
(structure-assignment-p (find-assignment register assignments)))
+(defun* list-assignment-p ((assignment register-assignment))
+ (:returns boolean)
+ "Return whether the given assignment pair is a (Prolog) list assignment."
+ (and (listp (cdr assignment))
+ (eql (cadr assignment) :list)))
+
+(defun* list-register-p ((register register)
+ (assignments register-assignment-list))
+ (:returns boolean)
+ "Return whether the given register contains a (Prolog) list assignment."
+ (list-assignment-p (find-assignment register assignments)))
+
+
;;;; Parsing
;;; You might want to grab a coffee for this one.
;;;
@@ -299,25 +323,41 @@
(make-temporary-register
(vector-push-extend var local-registers)
arity))
+ (store-temporary (contents preallocated-register)
+ ;; If we've been given a register to hold this thing (i.e. we're
+ ;; parsing a top-level argument) use it. Otherwise allocate a fresh
+ ;; one.
+ ;;
+ ;; Note that structures/lists always live in local registers, never
+ ;; permanent ones.
+ (let ((reg (or preallocated-register
+ (vector-push-extend nil local-registers))))
+ (setf (aref local-registers reg) contents)
+ (make-temporary-register reg arity)))
(parse-variable (var)
;; If we've already seen this variable just return the register it's
;; in, otherwise allocate a register for it and return that.
(or (find-variable var)
(store-variable var)))
- (parse-structure (structure reg)
+ (parse-structure (structure register)
(destructuring-bind (functor . arguments) structure
- ;; If we've been given a register to hold this structure (i.e.
- ;; we're parsing a top-level argument) use it. Otherwise allocate
- ;; a fresh one. Note that structures always live in local
- ;; registers, never permanent ones.
- (let ((reg (or reg (vector-push-extend nil local-registers))))
- (setf (aref local-registers reg)
- (cons functor (mapcar #'parse arguments)))
- (make-temporary-register reg arity))))
+ (store-temporary
+ (list* :structure functor (mapcar #'parse arguments))
+ register)))
+ (parse-list (list &optional register)
+ (destructuring-bind (head . tail) list
+ (store-temporary
+ (list :list
+ (parse head)
+ (if (consp tail)
+ (parse-list tail) ; [a, ...]
+ (parse tail))) ; [a | END]
+ register)))
(parse (term &optional register)
(cond
((variablep term) (parse-variable term))
((symbolp term) (parse (list term) register)) ; f -> f/0
+ ((prolog-list-p term) (parse-list (second term) register))
((listp term) (parse-structure term register))
(t (error "Cannot parse term ~S." term))))
(make-assignment-list (registers register-maker)
@@ -360,7 +400,8 @@
;;;
;;; into something like:
;;;
-;;; X2 <- q(X1, X3), X0 <- p(X1, X2)
+;;; X2 <- q(X1, X3)
+;;; X0 <- p(X1, X2)
(defun find-dependencies (assignments)
"Return a list of dependencies amongst the given registers.
@@ -371,20 +412,27 @@
(mapcan
(lambda (assignment)
(cond
- ; Variable assignments (X1 <- Foo) don't depend on anything else.
+ ;; Variable assignments (X1 <- Foo) don't depend on anything else.
((variable-assignment-p assignment)
())
- ; Register assignments (A0 <- X5) have one obvious dependency.
+ ;; Register assignments (A0 <- X5) have one obvious dependency.
((register-assignment-p assignment)
(destructuring-bind (argument . contents) assignment
(list `(,contents . ,argument))))
- ; Structure assignments depend on all the functor's arguments.
+ ;; Structure assignments depend on all the functor's arguments.
((structure-assignment-p assignment)
- (destructuring-bind (target . (functor . reqs))
+ (destructuring-bind (target . (tag functor . reqs))
assignment
- (declare (ignore functor))
+ (declare (ignore tag functor))
(loop :for req :in reqs
:collect (cons req target))))
+ ;; Prolog lists/pairs depend on their contents.
+ ((list-assignment-p assignment)
+ (destructuring-bind (target . (tag head tail))
+ assignment
+ (declare (ignore tag))
+ (list (cons head target)
+ (cons tail target))))
(t (error "Cannot find dependencies for assignment ~S." assignment))))
assignments))
@@ -429,21 +477,29 @@
(mapcan
(lambda (ass)
;; Take a single assignment like:
- ;; X1 = f(X4, Y1) (X1 . (f X4 Y1))
+ ;; X1 = f(X4, Y1) (X1 . (:structure f X4 Y1))
;; A0 = X5 (A0 . X5)
+ ;; X2 = [X3, Y2] (X2 . (:list X3 Y2))
;;
;; And turn it into a stream of tokens:
;; (X1 = f/2), X4, Y1 ((:structure X1 f 2) X4 Y1
- ;; (A0 = X5) (:argument A0 X5))
+ ;; (A0 = X5) (:argument A0 X5)
+ ;; (X2 = LIST), X3, Y2 (:list X2) X3 Y2)
(if (register-assignment-p ass)
;; It might be a register assignment for an argument register.
(destructuring-bind (argument-register . target-register) ass
(list (list :argument argument-register target-register)))
- ;; Otherwise it's a structure assignment. We know the others have
- ;; gotten flattened away by now.
- (destructuring-bind (register . (functor . arguments)) ass
- (cons (list :structure register functor (length arguments))
- arguments))))
+ ;; Otherwise it's a structure or list.
+ (destructuring-bind (register . (tag . body)) ass
+ (ecase tag
+ (:structure
+ (destructuring-bind (functor . arguments) body
+ (cons (list :structure register functor (length arguments))
+ arguments)))
+ (:list
+ (list `(:list ,register)
+ (first body)
+ (second body)))))))
assignments))
@@ -518,9 +574,11 @@
('(:argument nil :program :stack) :get-value-stack)
('(:argument nil :query :local) :put-value-local)
('(:argument nil :query :stack) :put-value-stack)
- ;; Structures can only live locally, they never go on the stack
- ('(:structure nil :program :local) :get-structure-local)
- ('(:structure nil :query :local) :put-structure-local)
+ ;; Structures and lists can only live locally, they never go on the stack
+ ('(:structure nil :program :local) :get-structure)
+ ('(:structure nil :query :local) :put-structure)
+ ('(:list nil :program :local) :get-list)
+ ('(:list nil :query :local) :put-list)
('(:register t :program :local) :unify-variable-local)
('(:register t :program :stack) :unify-variable-stack)
('(:register t :query :local) :set-variable-local)
@@ -561,6 +619,10 @@
(push-instruction (find-opcode :structure nil mode destination-register)
(wam-ensure-functor-index wam (cons functor arity))
destination-register))
+ (handle-list (register)
+ (push register seen)
+ (push-instruction (find-opcode :list nil mode register)
+ register))
(handle-call (functor arity)
;; CALL functor
(push-instruction :call
@@ -582,6 +644,8 @@
(member (register-type destination-register)
'(:local :argument)))
(handle-structure destination-register functor arity))
+ (`(:list ,register)
+ (handle-list register))
(`(:call ,functor ,arity)
(handle-call functor arity))
((guard register
@@ -810,14 +874,14 @@
:do
(match (circle-value node)
- ((guard `(:put-structure-local ,functor ,register)
+ ((guard `(:put-structure ,functor ,register)
(constant-p functor))
(setf node
(if (register-argument-p register)
(optimize-put-constant node functor register)
(optimize-set-constant node functor register))))
- ((guard `(:get-structure-local ,functor ,register)
+ ((guard `(:get-structure ,functor ,register)
(constant-p functor))
(setf node
(if (register-argument-p register)
@@ -836,7 +900,7 @@
(defun render-opcode (opcode)
(ecase opcode
- (:get-structure-local +opcode-get-structure-local+)
+ (:get-structure +opcode-get-structure+)
(:unify-variable-local +opcode-unify-variable-local+)
(:unify-variable-stack +opcode-unify-variable-stack+)
(:unify-value-local +opcode-unify-value-local+)
@@ -845,7 +909,7 @@
(:get-variable-stack +opcode-get-variable-stack+)
(:get-value-local +opcode-get-value-local+)
(:get-value-stack +opcode-get-value-stack+)
- (:put-structure-local +opcode-put-structure-local+)
+ (:put-structure +opcode-put-structure+)
(:set-variable-local +opcode-set-variable-local+)
(:set-variable-stack +opcode-set-variable-stack+)
(:set-value-local +opcode-set-value-local+)
@@ -857,6 +921,8 @@
(:put-constant +opcode-put-constant+)
(:get-constant +opcode-get-constant+)
(:set-constant +opcode-set-constant+)
+ (:get-list +opcode-get-list+)
+ (:put-list +opcode-put-list+)
(:unify-constant +opcode-unify-constant+)
(:call +opcode-call+)
(:proceed +opcode-proceed+)
--- a/src/wam/constants.lisp Thu Jun 02 10:36:29 2016 +0000
+++ b/src/wam/constants.lisp Thu Jun 02 13:42:58 2016 +0000
@@ -39,6 +39,9 @@
(define-constant +tag-constant+ #b100
:documentation "A constant (i.e. a 0-arity functor).")
+(define-constant +tag-list+ #b101
+ :documentation "A Prolog list.")
+
(define-constant +register-count+ 2048
:documentation "The number of local registers the WAM has available.")
@@ -101,7 +104,7 @@
;;; Program
-(define-constant +opcode-get-structure-local+ 1)
+(define-constant +opcode-get-structure+ 1)
(define-constant +opcode-unify-variable-local+ 2)
(define-constant +opcode-unify-variable-stack+ 3)
(define-constant +opcode-unify-value-local+ 4)
@@ -113,7 +116,7 @@
;;; Query
-(define-constant +opcode-put-structure-local+ 10)
+(define-constant +opcode-put-structure+ 10)
(define-constant +opcode-set-variable-local+ 11)
(define-constant +opcode-set-variable-stack+ 12)
(define-constant +opcode-set-value-local+ 13)
@@ -134,11 +137,17 @@
(define-constant +opcode-retry+ 25)
(define-constant +opcode-trust+ 26)
+
;;; Constants
(define-constant +opcode-get-constant+ 27)
(define-constant +opcode-set-constant+ 28)
(define-constant +opcode-put-constant+ 29)
(define-constant +opcode-unify-constant+ 30)
+;;; Lists
+(define-constant +opcode-get-list+ 31)
+(define-constant +opcode-put-list+ 32)
+
+
;;;; Debug Config
(defparameter *off-by-one* nil)
--- a/src/wam/dump.lisp Thu Jun 02 10:36:29 2016 +0000
+++ b/src/wam/dump.lisp Thu Jun 02 13:42:58 2016 +0000
@@ -172,13 +172,13 @@
(pretty-arguments arguments)
(first arguments)))
-(defmethod instruction-details ((opcode (eql +opcode-get-structure-local+)) arguments functor-list)
+(defmethod instruction-details ((opcode (eql +opcode-get-structure+)) arguments functor-list)
(format nil "GETS~A ; X~A = ~A"
(pretty-arguments arguments)
(second arguments)
(pretty-functor (first arguments) functor-list)))
-(defmethod instruction-details ((opcode (eql +opcode-put-structure-local+)) arguments functor-list)
+(defmethod instruction-details ((opcode (eql +opcode-put-structure+)) arguments functor-list)
(format nil "PUTS~A ; X~A <- new ~A"
(pretty-arguments arguments)
(second arguments)
@@ -259,6 +259,16 @@
(pretty-arguments arguments)
(pretty-functor (first arguments) functor-list)))
+(defmethod instruction-details ((opcode (eql +opcode-get-list+)) arguments functor-list)
+ (format nil "GLST~A ; X~A = [vvv | vvv]"
+ (pretty-arguments arguments)
+ (first arguments)))
+
+(defmethod instruction-details ((opcode (eql +opcode-put-list+)) arguments functor-list)
+ (format nil "PLST~A ; X~A = [vvv | vvv]"
+ (pretty-arguments arguments)
+ (first arguments)))
+
(defun dump-code-store (wam code-store
&optional
--- a/src/wam/types.lisp Thu Jun 02 10:36:29 2016 +0000
+++ b/src/wam/types.lisp Thu Jun 02 13:42:58 2016 +0000
@@ -45,7 +45,7 @@
(deftype opcode ()
- '(integer 0 30))
+ '(integer 0 32))
(deftype stack-frame-size ()
--- a/src/wam/vm.lisp Thu Jun 02 10:36:29 2016 +0000
+++ b/src/wam/vm.lisp Thu Jun 02 13:42:58 2016 +0000
@@ -1,5 +1,4 @@
(in-package #:bones.wam)
-(named-readtables:in-readtable :fare-quasiquote)
;;;; Config
(defparameter *break-on-fail* nil)
@@ -22,6 +21,16 @@
"
(wam-heap-push! wam (make-cell-structure (1+ (wam-heap-pointer wam)))))
+(defun* push-new-list! ((wam wam))
+ (:returns (values cell heap-index))
+ "Push a new list cell onto the heap.
+
+ The list cell's value will point at the next address, so make sure you push
+ something there too!
+
+ "
+ (wam-heap-push! wam (make-cell-list (1+ (wam-heap-pointer wam)))))
+
(defun* push-new-functor! ((wam wam) (functor functor-index))
(:returns (values cell heap-index))
"Push a new functor cell onto the heap."
@@ -66,6 +75,13 @@
(cell-value constant-cell-2)))
+(defmacro with-cell ((address-symbol cell-symbol) wam target &body body)
+ (once-only (wam target)
+ `(let* ((,address-symbol (deref ,wam ,target))
+ (,cell-symbol (wam-store-cell ,wam ,address-symbol)))
+ ,@body)))
+
+
;;;; "Ancillary" Functions
(defun* backtrack! ((wam wam))
(:returns :void)
@@ -176,6 +192,13 @@
(when (not (constants-match-p cell-1 cell-2))
(backtrack! wam)))
+ ;; Otherwise if they're both lists, make sure their contents match.
+ ((and (cell-list-p cell-1) (cell-list-p cell-2))
+ (wam-unification-stack-push! wam (cell-value cell-1))
+ (wam-unification-stack-push! wam (cell-value cell-2))
+ (wam-unification-stack-push! wam (1+ (cell-value cell-1)))
+ (wam-unification-stack-push! wam (1+ (cell-value cell-2))))
+
;; Otherwise if they're both structure cells, make sure they match
;; and then schedule their subterms to be unified.
((and (cell-structure-p cell-1) (cell-structure-p cell-2))
@@ -261,7 +284,7 @@
;;;; Query Instructions
-(define-instruction %put-structure-local
+(define-instruction %put-structure
((wam wam)
(functor functor-index)
(register register-index))
@@ -269,6 +292,12 @@
(make-cell-structure
(nth-value 1 (push-new-functor! wam functor)))))
+(define-instruction %put-list
+ ((wam wam)
+ (register register-index))
+ (setf (wam-local-register wam register)
+ (make-cell-list (wam-heap-pointer wam))))
+
(define-instructions (%set-variable-local %set-variable-stack)
((wam wam)
(register register-index))
@@ -297,26 +326,26 @@
;;;; Program Instructions
-(define-instruction %get-structure-local ((wam wam)
- (functor functor-index)
- (register register-index))
+(define-instruction %get-structure ((wam wam)
+ (functor functor-index)
+ (register register-index))
(with-accessors ((mode wam-mode) (s wam-subterm)) wam
- (let* ((addr (deref wam register))
- (cell (wam-store-cell wam addr)))
+ (with-cell (addr cell) wam register
(cond
- ;; If the register points at a reference cell, we push two new cells onto
- ;; the heap:
+ ;; If the register points at a reference cell, we push two new cells
+ ;; onto the heap:
;;
;; | N | STR | N+1 |
;; | N+1 | FUN | f/n |
;; | | | | <- S
;;
- ;; Then we bind this reference cell to point at the new structure, set the
- ;; S register to point beneath it and flip over to write mode.
+ ;; Then we bind this reference cell to point at the new structure, set
+ ;; the S register to point beneath it and flip over to write mode.
;;
;; It seems a bit confusing that we don't push the rest of the structure
- ;; stuff on the heap after it too. But that's going to happen in the next
- ;; few instructions (which will be unify-*'s, executed in write mode).
+ ;; stuff on the heap after it too. But that's going to happen in the
+ ;; next few instructions (which will be unify-*'s, executed in write
+ ;; mode).
((cell-reference-p cell)
(let ((structure-address (nth-value 1 (push-new-structure! wam)))
(functor-address (nth-value 1 (push-new-functor! wam functor))))
@@ -348,8 +377,27 @@
(setf mode :read
s (1+ functor-address))
(backtrack! wam))))
+
(t (backtrack! wam))))))
+(define-instruction %get-list ((wam wam)
+ (register register-index))
+ (with-cell (addr cell) wam register
+ (cond
+ ;; If the register points at a reference (unbound, because we deref'ed) we
+ ;; bind it to a list and flip into write mode to write the upcoming two
+ ;; things as its contents.
+ ((cell-reference-p cell)
+ (bind! wam addr (push-new-list! wam))
+ (setf (wam-mode wam) :write))
+
+ ;; If this is a list, we need to unify its subterms.
+ ((cell-list-p cell)
+ (setf (wam-mode wam) :read
+ (wam-subterm wam) (cell-value cell)))
+
+ (t (backtrack! wam)))))
+
(define-instructions (%unify-variable-local %unify-variable-stack)
((wam wam)
(register register-index))
@@ -484,8 +532,7 @@
(defun* %%match-constant ((wam wam)
(constant functor-index)
(address store-index))
- (let* ((addr (deref wam address))
- (cell (wam-store-cell wam addr)))
+ (with-cell (addr cell) wam address
(cond
((cell-reference-p cell)
(setf (wam-store-cell wam addr)
@@ -561,6 +608,8 @@
((cell-null-p cell) "NULL?!")
((cell-reference-p cell) (extract-var (cell-value cell)))
((cell-structure-p cell) (recur (cell-value cell)))
+ ((cell-list-p cell) (cons (recur (cell-value cell))
+ (recur (1+ (cell-value cell)))))
((cell-constant-p cell)
(wam-functor-symbol wam (cell-value cell)))
((cell-functor-p cell)
@@ -598,7 +647,7 @@
(break "About to execute instruction at ~4,'0X" pc))
(eswitch (opcode)
;; Query
- (+opcode-put-structure-local+ (instruction %put-structure-local 2))
+ (+opcode-put-structure+ (instruction %put-structure 2))
(+opcode-set-variable-local+ (instruction %set-variable-local 1))
(+opcode-set-variable-stack+ (instruction %set-variable-stack 1))
(+opcode-set-value-local+ (instruction %set-value-local 1))
@@ -608,7 +657,7 @@
(+opcode-put-value-local+ (instruction %put-value-local 2))
(+opcode-put-value-stack+ (instruction %put-value-stack 2))
;; Program
- (+opcode-get-structure-local+ (instruction %get-structure-local 2))
+ (+opcode-get-structure+ (instruction %get-structure 2))
(+opcode-unify-variable-local+ (instruction %unify-variable-local 1))
(+opcode-unify-variable-stack+ (instruction %unify-variable-stack 1))
(+opcode-unify-value-local+ (instruction %unify-value-local 1))
@@ -622,6 +671,9 @@
(+opcode-get-constant+ (instruction %get-constant 2))
(+opcode-set-constant+ (instruction %set-constant 1))
(+opcode-unify-constant+ (instruction %unify-constant 1))
+ ;; List
+ (+opcode-put-list+ (instruction %put-list 1))
+ (+opcode-get-list+ (instruction %get-list 1))
;; Choice
(+opcode-try+ (instruction %try 1))
(+opcode-retry+ (instruction %retry 1))
--- a/src/wam/wam.lisp Thu Jun 02 10:36:29 2016 +0000
+++ b/src/wam/wam.lisp Thu Jun 02 13:42:58 2016 +0000
@@ -127,7 +127,8 @@
wam-heap-cell
(setf wam-heap-cell)
wam-heap-pointer
- (setf wam-heap-pointer)))
+ (setf wam-heap-pointer)
+ wam-heap-push!))
(defun* wam-heap-pointer-unset-p ((wam wam) (address heap-index))
(:returns boolean)
@@ -220,7 +221,7 @@
(defun* assert-inside-stack ((wam wam) (address store-index))
(:returns :void)
- (declare (ignore wam address))
+ (declare (ignorable wam address))
(policy-cond:policy-cond
((>= debug 2)
(progn
--- a/test/wam.lisp Thu Jun 02 10:36:29 2016 +0000
+++ b/test/wam.lisp Thu Jun 02 13:42:58 2016 +0000
@@ -50,7 +50,11 @@
(likes :who cats)))
(rules ((narcissist :person)
- (likes :person :person))))
+ (likes :person :person)))
+
+ (rules ((member :x '(:x . :rest)))
+ ((member :x '(:y . :rest))
+ (member :x :rest))))
db))
(defparameter *test-database* (make-test-database))
@@ -69,9 +73,16 @@
`(with-database *test-database*
(return-all ,@query)))
-(defmacro check (query)
- `(with-database *test-database*
- (nth-value 1 (return-one ,query))))
+
+(defmacro should-fail (&body queries)
+ `(progn
+ ,@(loop :for query :in queries :collect
+ `(is (results= nil (q ,query))))))
+
+(defmacro should-return (&body queries)
+ `(progn
+ ,@(loop :for (query results) :in queries :collect
+ `(is (results= ',results (q ,query))))))
;;;; Tests
@@ -107,27 +118,46 @@
(drinks :who :what)))))
(test basic-rules
- (is (results= '((:what snakes)
- (:what cats))
- (q (pets alice :what))))
+ (should-fail
+ (pets candace :what))
+
+ (should-return
+ ((pets alice :what)
+ ((:what snakes) (:what cats)))
+
+ ((pets bob :what)
+ ((:what cats)))
- (is (results= '((:what cats))
- (q (pets bob :what))))
+ ((pets :who snakes)
+ ((:who alice)))
- (is (results= '()
- (q (pets candace :what))))
+ ((likes kim :who)
+ ((:who tom)
+ (:who alice)
+ (:who kim)
+ (:who cats)))
+
+ ((likes sally :who)
+ ((:who tom)))
- (is (results= '((:who alice))
- (q (pets :who snakes))))
+ ((narcissist :person)
+ ((:person kim)))))
- (is (results= '((:who tom)
- (:who alice)
- (:who kim)
- (:who cats))
- (q (likes kim :who))))
-
- (is (results= '((:who tom))
- (q (likes sally :who))))
-
- (is (results= '((:person kim))
- (q (narcissist :person)))))
+(test lists
+ (should-fail
+ (member :anything nil)
+ (member a nil)
+ (member b '(a))
+ (member '(a) '(a))
+ (member a '('(a))))
+ (should-return
+ ((member :m '(a))
+ ((:m a)))
+ ((member :m '(a b))
+ ((:m a) (:m b)))
+ ((member :m '(a b a))
+ ((:m a) (:m b)))
+ ((member a '(a))
+ (nil))
+ ((member '(foo) '(a '(foo) b))
+ (nil))))