--- a/bones.asd Sat Jul 16 17:37:17 2016 +0000
+++ b/bones.asd Sat Jul 16 18:23:34 2016 +0000
@@ -8,8 +8,7 @@
:license "MIT/X11"
:version "0.0.1"
- :depends-on (#:defstar
- #:optima
+ :depends-on (#:optima
#:trivial-types
#:cl-arrows
#:policy-cond
--- a/examples/ggp-paip-interpreted.lisp Sat Jul 16 17:37:17 2016 +0000
+++ b/examples/ggp-paip-interpreted.lisp Sat Jul 16 18:23:34 2016 +0000
@@ -7,29 +7,29 @@
queue-empty-p queue-append))
-(defun* queue-contents ((q queue))
+(defun queue-contents (q)
(cdr q))
-(defun* make-queue ()
+(defun make-queue ()
(let ((q (cons nil nil)))
(setf (car q) q)))
-(defun* enqueue ((item t) (q queue))
+(defun enqueue (item q)
(setf (car q)
(setf (rest (car q))
(cons item nil)))
q)
-(defun* dequeue ((q queue))
+(defun dequeue (q)
(prog1
(pop (cdr q))
(if (null (cdr q))
(setf (car q) q))))
-(defun* queue-empty-p ((q queue))
+(defun queue-empty-p (q)
(null (queue-contents q)))
-(defun* queue-append ((q queue) (l list))
+(defun queue-append (q l)
(when l
(setf (car q)
(last (setf (rest (car q))
--- a/package.lisp Sat Jul 16 17:37:17 2016 +0000
+++ b/package.lisp Sat Jul 16 18:23:34 2016 +0000
@@ -1,7 +1,6 @@
(defpackage #:bones.utils
(:use
#:cl
- #:defstar
#:cl-arrows
#:bones.quickutils)
(:export
@@ -26,12 +25,10 @@
#:dequeue
#:queue-contents
#:queue-empty-p
- #:queue-append)
- (:shadowing-import-from #:cl-arrows
- #:->))
+ #:queue-append))
(defpackage #:bones.circle
- (:use #:cl #:defstar)
+ (:use #:cl)
(:export
#:circle
#:make-circle-with
@@ -67,7 +64,6 @@
(defpackage #:bones.wam
(:use
#:cl
- #:defstar
#:optima
#:cl-arrows
#:bones.circle
@@ -108,17 +104,13 @@
#:call
#:?
- #:!
- )
+ #:!)
(:import-from #:optima
- #:match)
- (:shadowing-import-from #:cl-arrows
- #:->))
+ #:match))
(defpackage #:bones.paip
(:use
#:cl
- #:defstar
#:bones.quickutils)
(:documentation "Test?")
(:export
--- a/src/circle.lisp Sat Jul 16 17:37:17 2016 +0000
+++ b/src/circle.lisp Sat Jul 16 18:23:34 2016 +0000
@@ -52,12 +52,12 @@
(defstruct circle prev value next)
-(defun* circle-tie ((c1 circle) (c2 circle))
+(defun circle-tie (c1 c2)
(setf (circle-next c1) c2
(circle-prev c2) c1))
-(defun* make-empty-circle ()
+(defun make-empty-circle ()
"Create an empty circle.
It will still contain a sentinel.
@@ -68,7 +68,7 @@
(slot-value circle 'next) circle)
circle))
-(defun* make-circle-with ((list list))
+(defun make-circle-with (list)
"Create a circle whose nodes contain the values in `list`."
(let ((sentinel (make-empty-circle)))
(loop :with prev = sentinel
@@ -81,7 +81,7 @@
(circle-tie current sentinel)))
sentinel))
-(defun* make-circle-between ((left circle) value (right circle))
+(defun make-circle-between (left value right)
;; L new R
(let ((c (make-circle :prev left
:value value
@@ -91,23 +91,23 @@
c))
-(defun* circle-sentinel-p ((circle circle))
+(defun circle-sentinel-p (circle)
"Return whether this circle node is the sentinel."
(eq (circle-value circle) +circle-sentinel+))
-(defun* circle-empty-p ((circle circle))
+(defun circle-empty-p (circle)
"Return whether this circle is empty."
(and (circle-sentinel-p circle)
(eql circle (circle-next circle))))
-(defun* circle-rotate ((circle circle) (n integer))
+(defun circle-rotate (circle n)
(cond
((> n 0) (circle-rotate (circle-next circle) (1- n)))
((< n 0) (circle-rotate (circle-prev circle) (1+ n)))
(t circle)))
-(defun* circle-nth ((circle circle) (n integer))
+(defun circle-nth (circle n)
(when (not (circle-sentinel-p circle))
(error "Can only call circle-nth on the sentinel."))
(circle-rotate circle
@@ -116,31 +116,31 @@
(1+ n))))
-(defun* circle-insert-before ((circle circle) value)
+(defun circle-insert-before (circle value)
;; L new old R
(let ((old circle)
(l (circle-prev circle)))
(make-circle-between l value old)))
-(defun* circle-insert-after ((circle circle) value)
+(defun circle-insert-after (circle value)
;; L old new R
(let ((old circle)
(r (circle-next circle)))
(make-circle-between old value r)))
-(defun* circle-insert-beginning ((circle circle) value)
+(defun circle-insert-beginning (circle value)
(when (not (circle-sentinel-p circle))
(error "Can only insert-beginning at the sentinel."))
(circle-insert-after circle value))
-(defun* circle-insert-end ((circle circle) value)
+(defun circle-insert-end (circle value)
(when (not (circle-sentinel-p circle))
"Can only insert-end at the sentinel.")
(circle-insert-before circle value))
-(defun* circle-prepend-circle ((circle circle) (other circle))
+(defun circle-prepend-circle (circle other)
(when (not (circle-sentinel-p circle))
(error "Can only prepend to the sentinel."))
(when (not (circle-sentinel-p other))
@@ -151,12 +151,12 @@
(circle-tie s (circle-next other))
(circle-tie (circle-prev other) r)))
-(defun* circle-prepend ((circle circle) values)
+(defun circle-prepend (circle values)
(unless (null values)
(circle-prepend-circle circle (make-circle-with values))))
-(defun* circle-append-circle ((circle circle) (other circle))
+(defun circle-append-circle (circle other)
(when (not (circle-sentinel-p circle))
(error "Can only append to the sentinel."))
(when (not (circle-sentinel-p other))
@@ -167,23 +167,23 @@
(circle-tie l (circle-next other))
(circle-tie (circle-prev other) s)))
-(defun* circle-append ((circle circle) values)
+(defun circle-append (circle values)
(unless (null values)
(circle-append-circle circle (make-circle-with values))))
-(defun* circle-forward ((circle circle))
+(defun circle-forward (circle)
(let ((next (circle-next circle)))
(when (not (circle-sentinel-p next))
next)))
-(defun* circle-backward ((circle circle))
+(defun circle-backward (circle)
(let ((prev (circle-prev circle)))
(when (not (circle-sentinel-p prev))
prev)))
-(defun* circle-remove ((circle circle))
+(defun circle-remove (circle)
;; L rem R
(when (circle-sentinel-p circle)
(error "Cannot remove sentinel."))
@@ -191,18 +191,18 @@
(r (circle-next circle)))
(circle-tie l r)))
-(defun* circle-backward-remove ((circle circle))
+(defun circle-backward-remove (circle)
(prog1
(circle-backward circle)
(circle-remove circle)))
-(defun* circle-forward-remove ((circle circle))
+(defun circle-forward-remove (circle)
(prog1
(circle-forward circle)
(circle-remove circle)))
-(defun* circle-replace ((circle circle) value)
+(defun circle-replace (circle value)
(when (circle-sentinel-p circle)
(error "Cannot replace sentinel."))
;; L new R
@@ -210,18 +210,18 @@
(r (circle-next circle)))
(make-circle-between l value r)))
-(defun* circle-backward-replace ((circle circle) value)
+(defun circle-backward-replace (circle value)
(prog1
(circle-backward circle)
(circle-replace circle value)))
-(defun* circle-forward-replace ((circle circle) value)
+(defun circle-forward-replace (circle value)
(prog1
(circle-forward circle)
(circle-replace circle value)))
-(defun* circle-splice ((circle circle) values)
+(defun circle-splice (circle values)
(if (null values)
(circle-remove circle)
(progn
@@ -234,18 +234,18 @@
(circle-tie l (circle-next new))
(circle-tie (circle-prev new) r)))))
-(defun* circle-backward-splice ((circle circle) values)
+(defun circle-backward-splice (circle values)
(prog1
(circle-backward circle)
(circle-splice circle values)))
-(defun* circle-forward-splice ((circle circle) values)
+(defun circle-forward-splice (circle values)
(prog1
(circle-forward circle)
(circle-splice circle values)))
-(defun* circle-to-list ((circle circle) &optional include-sentinel-p)
+(defun circle-to-list (circle &optional include-sentinel-p)
(loop
:with node = circle
:when (or include-sentinel-p
--- a/src/paip-compiled.lisp Sat Jul 16 17:37:17 2016 +0000
+++ b/src/paip-compiled.lisp Sat Jul 16 18:23:34 2016 +0000
@@ -51,14 +51,14 @@
(name (incf *var-counter*)) ; The variable's name (defaults to a new number)
(binding unbound)) ; The variable's binding (defaults to unbound)
-(defun* print-var ((var var) stream depth)
+(defun print-var (var stream depth)
(if (or (and (numberp *print-level*)
(>= depth *print-level*))
(var-p (deref var)))
(format stream "?~A" (var-name var))
(write var :stream stream)))
-(defun* bound-p ((var var))
+(defun bound-p (var)
"Return whether the given variable has been bound."
(not (eq (var-binding var) unbound)))
@@ -74,7 +74,7 @@
(defvar *trail* (make-array 200 :fill-pointer 0 :adjustable t)
"The trail of variable bindings performed so far.")
-(defun* set-binding! ((var var) value)
+(defun set-binding! (var value)
"Set `var`'s binding to `value` after saving it in the trail.
Always returns `t` (success).
@@ -85,7 +85,7 @@
(setf (var-binding var) value))
t)
-(defun* undo-bindings! ((old-trail integer))
+(defun undo-bindings! (old-trail)
"Undo all bindings back to a given point in the trail.
The point is specified by giving the desired fill pointer.
@@ -97,7 +97,7 @@
;;;; Unification
-(defun* unify! (x y)
+(defun unify! (x y)
"Destructively unify two expressions, returning whether it was successful.
Any variables in `x` and `y` may have their bindings set.
@@ -140,10 +140,7 @@
(compile-predicate symbol arity matching-arity-clauses)
(prolog-compile symbol other-arity-clauses))))
-(defun* clauses-with-arity
- ((clauses (trivial-types:proper-list clause))
- (test function)
- (arity non-negative-integer))
+(defun clauses-with-arity (clauses test arity)
"Return all clauses whose heads have the given arity."
(find-all arity clauses
:key #'(lambda (clause)
@@ -151,7 +148,7 @@
:test test))
-(defun* relation-arity ((relation relation))
+(defun relation-arity (relation)
"Return the number of arguments of the given relation.
For example: `(relation-arity '(likes sally cats))` => `2`
@@ -159,7 +156,7 @@
"
(length (relation-arguments relation)))
-(defun* relation-arguments ((relation relation))
+(defun relation-arguments (relation)
"Return the arguments of the given relation.
For example:
@@ -171,10 +168,7 @@
(rest relation))
-(defun* compile-predicate
- ((symbol symbol)
- (arity non-negative-integer)
- (clauses (trivial-types:proper-list clause)))
+(defun compile-predicate (symbol arity clauses)
"Compile all the clauses for the symbol+arity into a single Lisp function."
(let ((predicate (make-predicate symbol arity))
(parameters (make-parameters arity)))
@@ -186,13 +180,12 @@
(compile-clause parameters clause 'continuation))
clauses)))))))
-(defun* make-parameters ((arity non-negative-integer))
+(defun make-parameters (arity)
"Return the list (?arg1 ?arg2 ... ?argN)."
(loop :for i :from 1 :to arity
:collect (new-symbol '?arg i)))
-(defun* make-predicate ((symbol symbol)
- (arity non-negative-integer))
+(defun make-predicate (symbol arity)
"Returns (and interns) the symbol with the Prolog-style name symbol/arity."
(values (interned-symbol symbol '/ arity)))
--- a/src/paip.lisp Sat Jul 16 17:37:17 2016 +0000
+++ b/src/paip.lisp Sat Jul 16 18:23:34 2016 +0000
@@ -24,40 +24,35 @@
;;;; Unification
-(defun* variable-p (term)
+(defun variable-p (term)
"Return whether the given term is a logic variable."
(and (symbolp term)
(equal (char (symbol-name term) 0)
#\?)))
-(defun* get-binding ((variable logic-variable)
- (bindings binding-list))
+(defun get-binding (variable bindings)
"Return the binding (var . val) for the given variable, or nil."
(assoc variable bindings))
-(defun* has-binding ((variable logic-variable)
- (bindings binding-list))
+(defun has-binding (variable bindings)
(not (null (get-binding variable bindings))))
-(defun* binding-variable ((binding binding))
+(defun binding-variable (binding)
"Return the variable part of a binding."
(car binding))
-(defun* binding-value ((binding binding))
+(defun binding-value (binding)
"Return the value part of a binding."
(cdr binding))
-(defun* lookup ((variable logic-variable)
- (bindings binding-list))
+(defun lookup (variable bindings)
"Return the value the given variable is bound to."
(binding-value (get-binding variable bindings)))
-(defun* extend-bindings ((variable logic-variable)
- (value t)
- (bindings binding-list))
+(defun extend-bindings (variable value bindings)
"Add a binding (var . val) to the binding list (nondestructively)."
(cons (cons variable value)
(if (and (equal bindings no-bindings))
@@ -65,9 +60,7 @@
bindings)))
-(defun* check-occurs ((variable logic-variable)
- (target t)
- (bindings binding-list))
+(defun check-occurs (variable target bindings)
"Check whether the variable occurs somewhere in the target.
Takes the bindings into account. This is expensive.
@@ -145,8 +138,7 @@
;;;; Substitution
-(defun* substitute-bindings ((bindings binding-list)
- (form t))
+(defun substitute-bindings (bindings form)
"Substitute (recursively) the bindings into the given form."
(cond ((eq bindings fail) fail)
((eq bindings no-bindings) form)
--- a/src/utils.lisp Sat Jul 16 17:37:17 2016 +0000
+++ b/src/utils.lisp Sat Jul 16 18:23:34 2016 +0000
@@ -158,13 +158,13 @@
(size 0 :type fixnum))
-(defun* make-queue ()
+(defun make-queue ()
(make-queue%))
-(defun* queue-empty-p ((q queue))
+(defun queue-empty-p (q)
(zerop (queue-size q)))
-(defun* enqueue ((item t) (q queue))
+(defun enqueue (item q)
(let ((cell (cons item nil)))
(setf (queue-last q)
(if (queue-empty-p q)
@@ -172,12 +172,12 @@
(setf (cdr (queue-last q)) cell))))
(incf (queue-size q)))
-(defun* dequeue ((q queue))
+(defun dequeue (q)
(when (zerop (decf (queue-size q)))
(setf (queue-last q) nil))
(pop (queue-contents q)))
-(defun* queue-append ((q queue) (l list))
+(defun queue-append (q l)
(loop :for item :in l
:for size = (enqueue item q)
:finally (return size)))
@@ -185,7 +185,7 @@
;;;; Lookup Tables
(defmacro define-lookup
- (name (key key-type value-type default) documentation &rest entries)
+ (name (key value-type default) documentation &rest entries)
"Define a lookup function.
This macro defines a function that looks up a result in a constant array.
@@ -201,8 +201,7 @@
with that.
`key` should be a symbol that will be used as the argument for the lookup
- function. `key-type` should be its type and should be a subtype of
- (integer 0 some-small-number) if you want this to be efficient.
+ function.
`value-type` should be the type of your results.
@@ -228,7 +227,7 @@
:collect (getf entries i default))))
:test (lambda (x y) (declare (ignore x y)) t)) ; what could go wrong
(declaim (inline ,name))
- (defun* ,name ((,key ,key-type))
+ (defun ,name (,key)
,documentation
(the ,value-type (aref ,table ,key)))))))
--- a/src/wam/bytecode.lisp Sat Jul 16 17:37:17 2016 +0000
+++ b/src/wam/bytecode.lisp Sat Jul 16 18:23:34 2016 +0000
@@ -2,7 +2,7 @@
;;;; Opcodes
-(defun* opcode-name ((opcode opcode))
+(defun opcode-name (opcode)
(eswitch (opcode)
(+opcode-noop+ "NOOP")
@@ -47,7 +47,7 @@
(+opcode-get-lisp-object+ "GET-LISP-OBJECT")
(+opcode-put-lisp-object+ "PUT-LISP-OBJECT")))
-(defun* opcode-short-name ((opcode opcode))
+(defun opcode-short-name (opcode)
(eswitch (opcode)
(+opcode-noop+ "NOOP")
@@ -94,7 +94,7 @@
;;;; Instructions
-(define-lookup instruction-size (opcode opcode instruction-size 0)
+(define-lookup instruction-size (opcode instruction-size 0)
"Return the size of an instruction for the given opcode.
The size includes one word for the opcode itself and one for each argument.
@@ -145,7 +145,7 @@
;;;; Cells
-(define-lookup cell-type-name (type cell-type string "")
+(define-lookup cell-type-name (type string "")
"Return the full name of a cell type."
(#.+cell-type-null+ "NULL")
(#.+cell-type-structure+ "STRUCTURE")
@@ -156,7 +156,7 @@
(#.+cell-type-lisp-object+ "LISP-OBJECT")
(#.+cell-type-stack+ "STACK"))
-(define-lookup cell-type-short-name (type cell-type string "")
+(define-lookup cell-type-short-name (type string "")
"Return the short name of a cell type."
(#.+cell-type-null+ "NUL")
(#.+cell-type-structure+ "STR")
--- a/src/wam/compiler/0-data.lisp Sat Jul 16 17:37:17 2016 +0000
+++ b/src/wam/compiler/0-data.lisp Sat Jul 16 18:23:34 2016 +0000
@@ -12,7 +12,7 @@
;;;; Utils
(declaim (inline variablep))
-(defun* variablep (term)
+(defun variablep (term)
(and (symbolp term)
(char= (char (symbol-name term) 0) #\?)))
@@ -44,18 +44,18 @@
(number (required) :type register-number))
-(defun* make-temporary-register ((number register-number) (arity arity))
+(defun make-temporary-register (number arity)
(make-register (if (< number arity) :argument :local)
number))
-(defun* make-permanent-register ((number register-number))
+(defun make-permanent-register (number)
(make-register :permanent number))
-(defun* make-anonymous-register ()
+(defun make-anonymous-register ()
(make-register :anonymous 0))
-(defun* register-to-string ((register register))
+(defun register-to-string (register)
(if (eq (register-type register) :anonymous)
"__"
(format nil "~A~D"
@@ -71,20 +71,20 @@
(format stream (register-to-string object))))
-(defun* register-argument-p ((register register))
+(defun register-argument-p (register)
(eq (register-type register) :argument))
-(defun* register-temporary-p ((register register))
+(defun register-temporary-p (register)
(and (member (register-type register) '(:argument :local)) t))
-(defun* register-permanent-p ((register register))
+(defun register-permanent-p (register)
(eq (register-type register) :permanent))
-(defun* register-anonymous-p ((register register))
+(defun register-anonymous-p (register)
(eq (register-type register) :anonymous))
-(defun* register= ((r1 register) (r2 register))
+(defun register= (r1 r2)
(and (eq (register-type r1)
(register-type r2))
(= (register-number r1)
@@ -104,7 +104,7 @@
(anonymous-vars nil :type list))
-(defun* find-variables ((terms list))
+(defun find-variables (terms)
"Return the set of variables in `terms`."
(let ((variables nil))
(recursively ((term terms))
@@ -172,7 +172,7 @@
once))
-(defun* determine-clause-properties (head body)
+(defun determine-clause-properties (head body)
(let* ((clause
(cons head body))
(permanent-vars
--- a/src/wam/compiler/1-parsing.lisp Sat Jul 16 17:37:17 2016 +0000
+++ b/src/wam/compiler/1-parsing.lisp Sat Jul 16 18:23:34 2016 +0000
@@ -48,10 +48,11 @@
(object nil :type t))
-(defgeneric* node-children (node)
+(defgeneric node-children (node)
+ (:documentation
"Return the children of the given node.
- Presumably these will need to be traversed when allocating registers.")
+ Presumably these will need to be traversed when allocating registers."))
(defmethod node-children ((node vanilla-node))
(list))
@@ -66,7 +67,7 @@
(list (node-head node) (node-tail node)))
-(defun* nil-node-p ((node node))
+(defun nil-node-p (node)
"Return whether the given node is the magic nil/0 constant."
(and (typep node 'structure-node)
(eql (node-functor node) nil)
@@ -145,7 +146,7 @@
(dump-node node)))
-(defun* parse-list ((contents list))
+(defun parse-list (contents)
(if contents
(make-list-node :head (parse (car contents))
:tail (parse-list (cdr contents)))
@@ -153,14 +154,14 @@
:arity 0
:arguments ())))
-(defun* parse-list* ((contents list))
+(defun parse-list* (contents)
(destructuring-bind (next . remaining) contents
(if (null remaining)
(parse next)
(make-list-node :head (parse next)
:tail (parse-list* remaining)))))
-(defun* parse (term &optional top-level-argument)
+(defun parse (term &optional top-level-argument)
(cond
((variablep term)
(if top-level-argument
@@ -184,7 +185,7 @@
(make-lisp-object-node :object term))
(t (error "Cannot parse term ~S into a Prolog term." term))))
-(defun* parse-top-level (term)
+(defun parse-top-level (term)
(typecase term
(symbol (parse-top-level (list term))) ; c/0 -> (c/0)
(cons (destructuring-bind (functor . arguments) term
--- a/src/wam/compiler/2-register-allocation.lisp Sat Jul 16 17:37:17 2016 +0000
+++ b/src/wam/compiler/2-register-allocation.lisp Sat Jul 16 18:23:34 2016 +0000
@@ -149,7 +149,7 @@
(actual-arity 0 :type arity))
-(defun* find-variable ((state allocation-state) (variable symbol))
+(defun find-variable (state variable)
"Return the register that already contains this variable, or `nil` otherwise."
(or (when-let (r (position variable
(queue-contents
@@ -160,7 +160,7 @@
(make-permanent-register s))
nil))
-(defun* store-variable ((state allocation-state) (variable symbol))
+(defun store-variable (state variable)
"Assign `variable` to the next available local register.
It is assumed that `variable` is not already assigned to another register
@@ -174,7 +174,7 @@
:local
(1- (enqueue variable (allocation-state-local-registers state)))))
-(defun* ensure-variable ((state allocation-state) (variable symbol))
+(defun ensure-variable (state variable)
(or (find-variable state variable)
(store-variable state variable)))
@@ -185,17 +185,17 @@
(setf (,accessor ,instance) ,value-form))))
-(defun* variable-anonymous-p ((state allocation-state) (variable symbol))
+(defun variable-anonymous-p (state variable)
"Return whether `variable` is considered anonymous in `state`."
(and (member variable (allocation-state-anonymous-variables state)) t))
-(defun* allocate-variable-register ((state allocation-state) (variable symbol))
+(defun allocate-variable-register (state variable)
(if (variable-anonymous-p state variable)
(make-anonymous-register)
(ensure-variable state variable)))
-(defun* allocate-nonvariable-register ((state allocation-state))
+(defun allocate-nonvariable-register (state)
"Allocate and return a register for something that's not a variable."
;; We need to allocate registers for things like structures and lists, but we
;; never need to look them up later (like we do with variables), so we'll just
@@ -233,15 +233,13 @@
(allocate-nonvariable-register state)))
-(defun* allocate-argument-registers ((node top-level-node))
+(defun allocate-argument-registers (node)
(loop :for argument :in (top-level-node-arguments node)
:for i :from 0
:do (setf (node-register argument)
(make-register :argument i))))
-(defun* allocate-nonargument-registers ((node top-level-node)
- (clause-props clause-properties)
- &key nead)
+(defun allocate-nonargument-registers (node clause-props &key nead)
;; JESUS TAKE THE WHEEL
(let*
((actual-arity (top-level-node-arity node))
@@ -282,9 +280,7 @@
(allocate-register node allocation-state)
(recur (append remaining (node-children node))))))))
-(defun* allocate-registers ((node top-level-node)
- (clause-props clause-properties)
- &key nead)
+(defun allocate-registers (node clause-props &key nead)
(allocate-argument-registers node)
(allocate-nonargument-registers node clause-props :nead nead))
--- a/src/wam/compiler/3-flattening.lisp Sat Jul 16 17:37:17 2016 +0000
+++ b/src/wam/compiler/3-flattening.lisp Sat Jul 16 18:23:34 2016 +0000
@@ -80,7 +80,7 @@
(lisp-object-to-string (assignment-object assignment)))))
-(defgeneric* node-flatten (node))
+(defgeneric node-flatten (node))
(defmethod node-flatten (node)
nil)
@@ -109,7 +109,7 @@
:object (node-object node))))
-(defun* flatten-breadth-first ((tree top-level-node))
+(defun flatten-breadth-first (tree)
(let ((results nil))
(recursively ((node tree))
(when-let (assignment (node-flatten node))
@@ -117,7 +117,7 @@
(mapcar #'recur (node-children node)))
(nreverse results)))
-(defun* flatten-depth-first-post-order ((tree top-level-node))
+(defun flatten-depth-first-post-order (tree)
(let ((results nil))
(recursively ((node tree))
(mapcar #'recur (node-children node))
@@ -126,10 +126,10 @@
(nreverse results)))
-(defun* flatten-query ((tree top-level-node))
+(defun flatten-query (tree)
(flatten-depth-first-post-order tree))
-(defun* flatten-program ((tree top-level-node))
+(defun flatten-program (tree)
(flatten-breadth-first tree))
--- a/src/wam/compiler/4-tokenization.lisp Sat Jul 16 17:37:17 2016 +0000
+++ b/src/wam/compiler/4-tokenization.lisp Sat Jul 16 18:23:34 2016 +0000
@@ -48,7 +48,7 @@
(defclass cut-token (token) ())
-(defun* make-register-token ((register register))
+(defun make-register-token (register)
(values (make-instance 'register-token :register register)))
@@ -95,8 +95,8 @@
(format stream "CUT!")))
-(defgeneric* tokenize-assignment ((assignment register-assignment))
- "Tokenize `assignment` into a flat list of tokens.")
+(defgeneric tokenize-assignment (assignment)
+ (:documentation "Tokenize `assignment` into a flat list of tokens."))
(defmethod tokenize-assignment ((assignment structure-assignment))
(list* (make-instance 'structure-token
@@ -120,20 +120,18 @@
:register (assignment-register assignment)
:object (assignment-object assignment))))
-(defun* tokenize-assignments ((assignments list))
+(defun tokenize-assignments (assignments)
"Tokenize a flattened set of register assignments into a stream."
(mapcan #'tokenize-assignment assignments))
-(defun* tokenize-program-term (term (clause-props clause-properties))
+(defun tokenize-program-term (term clause-props)
"Tokenize `term` as a program term, returning its tokens."
(let ((tree (parse-top-level term)))
(allocate-registers tree clause-props :nead t)
(-> tree flatten-program tokenize-assignments)))
-(defun* tokenize-query-term (term
- (clause-props clause-properties)
- &key in-nead is-tail)
+(defun tokenize-query-term (term clause-props &key in-nead is-tail)
"Tokenize `term` as a query term, returning its tokens."
(let ((tree (parse-top-level term)))
(allocate-registers tree clause-props :nead in-nead)
--- a/src/wam/compiler/5-precompilation.lisp Sat Jul 16 17:37:17 2016 +0000
+++ b/src/wam/compiler/5-precompilation.lisp Sat Jul 16 18:23:34 2016 +0000
@@ -104,7 +104,7 @@
;;; on that rabbit hole).
-(defun* find-opcode-register ((first-seen boolean) (register register))
+(defun find-opcode-register (first-seen register)
(let ((register-variant (when register
(ecase (register-type register)
((:local :argument) :local)
@@ -120,24 +120,22 @@
(:stack :subterm-value-stack)
(:void :subterm-void)))))
-(defun* find-opcode-list ((mode keyword))
+(defun find-opcode-list (mode)
(ecase mode
(:program :get-list)
(:query :put-list)))
-(defun* find-opcode-lisp-object ((mode keyword))
+(defun find-opcode-lisp-object (mode)
(ecase mode
(:program :get-lisp-object)
(:query :put-lisp-object)))
-(defun* find-opcode-structure ((mode keyword))
+(defun find-opcode-structure (mode)
(ecase mode
(:program :get-structure)
(:query :put-structure)))
-(defun* find-opcode-argument ((first-seen boolean)
- (mode keyword)
- (register register))
+(defun find-opcode-argument (first-seen mode register)
(let ((register-variant (ecase (register-type register)
((:local :argument) :local)
((:permanent) :stack))))
@@ -158,7 +156,7 @@
(:stack :put-value-stack)))))))
-(defun* precompile-tokens ((head-tokens list) (body-tokens list))
+(defun precompile-tokens (head-tokens body-tokens)
"Generate a series of machine instructions from a stream of head and body
tokens.
@@ -270,7 +268,7 @@
instructions)))
-(defun* precompile-clause (head body)
+(defun precompile-clause (head body)
"Precompile the clause.
`head` should be the head of the clause for program clauses, or `nil` for
@@ -348,7 +346,7 @@
(values instructions clause-props))))
-(defun* precompile-query ((query list))
+(defun precompile-query (query)
"Compile `query`, returning the instructions and permanent variables.
`query` should be a list of goal terms.
@@ -360,7 +358,7 @@
(clause-permanent-vars clause-props))))
-(defun* find-predicate ((clause cons))
+(defun find-predicate (clause)
"Return the functor and arity of the predicate of `clause`."
;; ( (f ?x ?y) | head ||| clause
;; (foo ?x) || body |||
@@ -374,7 +372,7 @@
(t (error "Clause ~S has a malformed head." clause)))))
-(defun* precompile-rules ((rules list))
+(defun precompile-rules (rules)
"Compile a single predicate's `rules` into a list of instructions.
All the rules must for the same predicate. This is not checked, for
--- a/src/wam/compiler/6-optimization.lisp Sat Jul 16 17:37:17 2016 +0000
+++ b/src/wam/compiler/6-optimization.lisp Sat Jul 16 18:23:34 2016 +0000
@@ -13,21 +13,15 @@
;;; circle of instructions, doing one optimization each time.
-(defun* optimize-get-constant ((node circle)
- (constant fname)
- (register register))
+(defun optimize-get-constant (node constant register)
;; 1. get_structure c/0, Ai -> get_constant c, Ai
(circle-replace node `(:get-constant ,constant ,register)))
-(defun* optimize-put-constant ((node circle)
- (constant fname)
- (register register))
+(defun optimize-put-constant (node constant register)
;; 2. put_structure c/0, Ai -> put_constant c, Ai
(circle-replace node `(:put-constant ,constant ,register)))
-(defun* optimize-subterm-constant-query ((node circle)
- (constant fname)
- (register register))
+(defun optimize-subterm-constant-query (node constant register)
;; 3. put_structure c/0, Xi *** WE ARE HERE
;; ...
;; subterm_value Xi -> subterm_constant c
@@ -43,9 +37,7 @@
(circle-replace n `(:subterm-constant ,constant))
(return previous)))
-(defun* optimize-subterm-constant-program ((node circle)
- (constant fname)
- (register register))
+(defun optimize-subterm-constant-program (node constant register)
;; 4. subterm_variable Xi -> subterm_constant c
;; ...
;; get_structure c/0, Xi *** WE ARE HERE
@@ -60,7 +52,7 @@
(circle-replace n `(:subterm-constant ,constant))
(return (circle-backward-remove node))))
-(defun* optimize-constants ((instructions circle))
+(defun optimize-constants (instructions)
;; From the book and the erratum, there are four optimizations we can do for
;; constants (0-arity structures).
@@ -84,7 +76,7 @@
instructions)
-(defun* optimize-void-runs ((instructions circle))
+(defun optimize-void-runs (instructions)
;; We can optimize runs of N (:[unify/set]-void 1) instructions into a single
;; one that does all N at once.
(loop
@@ -109,7 +101,7 @@
instructions)
-(defun* optimize-instructions ((instructions circle))
+(defun optimize-instructions (instructions)
(->> instructions
(optimize-constants)
(optimize-void-runs)))
--- a/src/wam/compiler/7-rendering.lisp Sat Jul 16 17:37:17 2016 +0000
+++ b/src/wam/compiler/7-rendering.lisp Sat Jul 16 18:23:34 2016 +0000
@@ -22,10 +22,7 @@
(1- (instruction-size opcode))))
-(defun* code-push-instruction ((store generic-code-store)
- (opcode opcode)
- (arguments list)
- (address code-index))
+(defun code-push-instruction (store opcode arguments address)
"Push the given instruction into `store` at `address`.
`arguments` should be a list of `code-word`s.
@@ -39,7 +36,7 @@
(instruction-size opcode))
-(defun* render-opcode ((opcode-designator keyword))
+(defun render-opcode (opcode-designator)
(ecase opcode-designator
(:get-structure +opcode-get-structure+)
(:get-variable-local +opcode-get-variable-local+)
@@ -76,7 +73,7 @@
(:trust +opcode-trust+)
(:cut +opcode-cut+)))
-(defun* render-argument (argument)
+(defun render-argument (argument)
(cond
;; Ugly choice point args that'll be filled later...
((eq +choice-point-placeholder+ argument) 0)
@@ -87,10 +84,7 @@
;; Everything else just gets shoved right into the array.
(t argument)))
-(defun* render-bytecode ((store generic-code-store)
- (instructions circle)
- (start code-index)
- (limit code-index))
+(defun render-bytecode (store instructions start limit)
"Render `instructions` (a circle) into `store` starting at `start`.
Bail if ever pushed beyond `limit`.
@@ -134,22 +128,16 @@
:do (incf address size)))))
-(defun* render-query ((wam wam) (instructions circle))
+(defun render-query (wam instructions)
(render-bytecode (wam-code wam) instructions 0 +maximum-query-size+))
-(defun* mark-label ((wam wam)
- (functor symbol)
- (arity arity)
- (address code-index))
+(defun mark-label (wam functor arity address)
"Set the code label `functor`/`arity` to point at `address`."
(setf (wam-code-label wam functor arity)
address))
-(defun* render-rules ((wam wam)
- (functor symbol)
- (arity arity)
- (instructions circle))
+(defun render-rules (wam functor arity instructions)
;; Before we render the instructions, make the label point at where they're
;; about to go.
(mark-label wam functor arity (wam-code-pointer wam))
--- a/src/wam/compiler/8-ui.lisp Sat Jul 16 17:37:17 2016 +0000
+++ b/src/wam/compiler/8-ui.lisp Sat Jul 16 18:23:34 2016 +0000
@@ -8,7 +8,7 @@
;;; The final phase wraps everything else up into a sane UI.
-(defun* compile-query ((wam wam) (query list))
+(defun compile-query (wam query)
"Compile `query` into the query section of the WAM's code store.
`query` should be a list of goal terms.
@@ -22,7 +22,7 @@
(render-query wam instructions)
permanent-variables))
-(defun* compile-rules ((wam wam) (rules list))
+(defun compile-rules (wam rules)
"Compile `rules` into the WAM's code store.
Each rule in `rules` should be a clause consisting of a head term and zero or
--- a/src/wam/vm.lisp Sat Jul 16 17:37:17 2016 +0000
+++ b/src/wam/vm.lisp Sat Jul 16 18:23:34 2016 +0000
@@ -9,11 +9,11 @@
constants-match-p))
-(defun* push-unbound-reference! ((wam wam))
+(defun push-unbound-reference! (wam)
"Push a new unbound reference cell onto the heap, returning its address."
(wam-heap-push! wam +cell-type-reference+ (wam-heap-pointer wam)))
-(defun* push-new-structure! ((wam wam))
+(defun push-new-structure! (wam)
"Push a new structure cell onto the heap, returning its address.
The structure cell's value will point at the next address, so make sure you
@@ -22,7 +22,7 @@
"
(wam-heap-push! wam +cell-type-structure+ (1+ (wam-heap-pointer wam))))
-(defun* push-new-list! ((wam wam))
+(defun push-new-list! (wam)
"Push a new list cell onto the heap, returning its address.
The list cell's value will point at the next address, so make sure you push
@@ -31,28 +31,27 @@
"
(wam-heap-push! wam +cell-type-list+ (1+ (wam-heap-pointer wam))))
-(defun* push-new-functor! ((wam wam) (functor fname) (arity arity))
+(defun push-new-functor! (wam functor arity)
"Push a new functor cell pair onto the heap, returning its address."
(prog1
(wam-heap-push! wam +cell-type-functor+ functor)
(wam-heap-push! wam +cell-type-lisp-object+ arity)))
-(defun* push-new-constant! ((wam wam) (constant fname))
+(defun push-new-constant! (wam constant)
"Push a new constant cell onto the heap, returning its address."
(wam-heap-push! wam +cell-type-constant+ constant))
-(defun* functors-match-p ((f1 fname) (a1 arity)
- (f2 fname) (a2 arity))
+(defun functors-match-p (f1 a1 f2 a2)
"Return whether the two functor cell values represent the same functor."
(and (eq f1 f2)
(= a1 a2)))
-(defun* constants-match-p ((c1 fname) (c2 fname))
+(defun constants-match-p (c1 c2)
"Return whether the two constant cell values unify."
(eq c1 c2))
-(defun* lisp-objects-match-p ((o1 t) (o2 t))
+(defun lisp-objects-match-p (o1 o2)
"Return whether the two lisp object cells unify."
(eql o1 o2))
@@ -61,7 +60,7 @@
(declaim (inline deref unbind! trail!))
-(defun* backtrack! ((wam wam))
+(defun backtrack! (wam)
"Backtrack after a failure."
(if (wam-backtrack-pointer-unset-p wam)
(setf (wam-fail wam) t)
@@ -69,12 +68,12 @@
(wam-cut-pointer wam) (wam-stack-choice-cc wam)
(wam-backtracked wam) t)))
-(defun* trail! ((wam wam) (address store-index))
+(defun trail! (wam address)
"Push the given address onto the trail (but only if necessary)."
(when (< address (wam-heap-backtrack-pointer wam))
(wam-trail-push! wam address)))
-(defun* unbind! ((wam wam) (address store-index))
+(defun unbind! (wam address)
"Unbind the reference cell at `address`.
No error checking is done, so please don't try to unbind something that's not
@@ -83,14 +82,12 @@
"
(wam-set-store-cell! wam address +cell-type-reference+ address))
-(defun* unwind-trail! ((wam wam)
- (trail-start trail-index)
- (trail-end trail-index))
+(defun unwind-trail! (wam trail-start trail-end)
"Unbind all the things in the given range of the trail."
(loop :for i :from trail-start :below trail-end :do
(unbind! wam (wam-trail-value wam i))))
-(defun* tidy-trail! ((wam wam))
+(defun tidy-trail! (wam)
(with-accessors ((tr wam-trail-pointer)
(h wam-heap-pointer)
(hb wam-heap-backtrack-pointer)
@@ -114,7 +111,7 @@
(wam-trail-value wam (1- tr)))
(decf tr))))))
-(defun* deref ((wam wam) (address store-index))
+(defun deref (wam address)
"Dereference the address in the WAM store to its eventual destination.
If the address is a variable that's bound to something, that something will be
@@ -130,7 +127,7 @@
(setf address ref))) ; bound ref
(t (return address))))) ; non-ref
-(defun* bind! ((wam wam) (address-1 store-index) (address-2 store-index))
+(defun bind! (wam address-1 address-2)
"Bind the unbound reference cell to the other.
`bind!` takes two addresses as arguments. You are expected to have `deref`ed
@@ -171,7 +168,7 @@
;; wut
(t (error "At least one cell must be an unbound reference when binding."))))
-(defun* unify! ((wam wam) (a1 store-index) (a2 store-index))
+(defun unify! (wam a1 a2)
(setf (wam-fail wam) nil)
(wam-unification-stack-push! wam a1 a2)
@@ -268,7 +265,7 @@
;;;
;;; To make the process of defining these two "variants" less excruciating we
;;; have these two macros. `define-instruction` (singular) is just a little
-;;; sugar around `defun*`, for those instructions that don't deal with
+;;; sugar around `defun`, for those instructions that don't deal with
;;; arguments.
;;;
;;; `define-instructions` (plural) is the awful one. You pass it a pair of
@@ -290,13 +287,14 @@
((name &optional should-inline) lambda-list &body body)
"Define an instruction function.
- This is just sugar over `defun*`.
+ This is just sugar over `defun`.
"
`(progn
(declaim (,(if should-inline 'inline 'notinline) ,name))
- (defun* ,name ,lambda-list
- ,@body)))
+ (defun ,name ,lambda-list
+ ,@body
+ nil)))
(defmacro define-instructions
((local-name stack-name &optional should-inline) lambda-list &body body)
@@ -329,19 +327,13 @@
;;;; Query Instructions
-(define-instruction (%put-structure)
- ((wam wam)
- (functor fname)
- (arity arity)
- (register register-index))
+(define-instruction (%put-structure) (wam functor arity register)
(wam-set-local-register! wam register
+cell-type-structure+
(push-new-functor! wam functor arity))
(setf (wam-mode wam) :write))
-(define-instruction (%put-list)
- ((wam wam)
- (register register-index))
+(define-instruction (%put-list) (wam register)
(wam-set-local-register! wam register
+cell-type-list+
(wam-heap-pointer wam))
@@ -349,27 +341,20 @@
(define-instructions (%put-variable-local %put-variable-stack)
- ((wam wam)
- (register register-index)
- (argument register-index))
+ (wam register argument)
(let ((ref (push-unbound-reference! wam)))
(%wam-copy-to-register% wam register ref)
(wam-copy-to-local-register! wam argument ref)
(setf (wam-mode wam) :write)))
(define-instructions (%put-value-local %put-value-stack)
- ((wam wam)
- (register register-index)
- (argument register-index))
+ (wam register argument)
(wam-copy-to-local-register! wam argument (%wam-register% wam register))
(setf (wam-mode wam) :write))
;;;; Program Instructions
-(define-instruction (%get-structure) ((wam wam)
- (functor fname)
- (arity arity)
- (register register-index))
+(define-instruction (%get-structure) (wam functor arity register)
(cell-typecase (wam (deref wam register) address)
;; If the register points at an unbound reference cell, we push three new
;; cells onto the heap:
@@ -417,8 +402,7 @@
;; Otherwise we can't unify, so backtrack.
(t (backtrack! wam))))
-(define-instruction (%get-list) ((wam wam)
- (register register-index))
+(define-instruction (%get-list) (wam register)
(cell-typecase (wam (deref wam register) address)
;; 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
@@ -437,22 +421,17 @@
(define-instructions (%get-variable-local %get-variable-stack)
- ((wam wam)
- (register register-index)
- (argument register-index))
+ (wam register argument)
(%wam-copy-to-register% wam register argument))
(define-instructions (%get-value-local %get-value-stack)
- ((wam wam)
- (register register-index)
- (argument register-index))
+ (wam register argument)
(unify! wam register argument))
;;;; Subterm Instructions
(define-instructions (%subterm-variable-local %subterm-variable-stack)
- ((wam wam)
- (register register-index))
+ (wam register)
(%wam-copy-to-register% wam register
(ecase (wam-mode wam)
(:read (wam-subterm wam))
@@ -460,8 +439,7 @@
(incf (wam-subterm wam)))
(define-instructions (%subterm-value-local %subterm-value-stack)
- ((wam wam)
- (register register-index))
+ (wam register)
(ecase (wam-mode wam)
(:read (unify! wam register (wam-subterm wam)))
(:write (wam-heap-push! wam
@@ -469,7 +447,7 @@
(%wam-register-value% wam register))))
(incf (wam-subterm wam)))
-(define-instruction (%subterm-void) ((wam wam) (n arity))
+(define-instruction (%subterm-void) (wam n)
(ecase (wam-mode wam)
(:read (incf (wam-subterm wam) n))
(:write (repeat n
@@ -480,11 +458,7 @@
(declaim (inline %%procedure-call %%dynamic-procedure-call))
-(defun* %%procedure-call ((wam wam)
- (functor fname)
- (arity arity)
- (program-counter-increment instruction-size)
- (is-tail boolean))
+(defun %%procedure-call (wam functor arity program-counter-increment is-tail)
(let* ((target (wam-code-label wam functor arity)))
(if (not target)
;; Trying to call an unknown procedure.
@@ -502,15 +476,15 @@
(wam-program-counter wam) ; jump
target)))))
-(defun* %%dynamic-procedure-call ((wam wam) (is-tail boolean))
- (flet*
+(defun %%dynamic-procedure-call (wam is-tail)
+ (flet
((%go (functor arity)
(if is-tail
(%%procedure-call
wam functor arity (instruction-size +opcode-dynamic-jump+) t)
(%%procedure-call
wam functor arity (instruction-size +opcode-dynamic-call+) nil)))
- (load-arguments ((n arity) start-address)
+ (load-arguments (n start-address)
(loop :for arg :from 0 :below n
:for source :from start-address
:do (wam-copy-to-local-register! wam arg source))))
@@ -536,29 +510,29 @@
(t (error "Cannot dynamically call something other than a structure.")))))
-(define-instruction (%jump) ((wam wam) (functor fname) (arity arity))
+(define-instruction (%jump) (wam functor arity)
(%%procedure-call wam functor arity
(instruction-size +opcode-jump+)
t))
-(define-instruction (%call) ((wam wam) (functor fname) (arity arity))
+(define-instruction (%call) (wam functor arity)
(%%procedure-call wam functor arity
(instruction-size +opcode-call+)
nil))
-(define-instruction (%dynamic-call) ((wam wam))
+(define-instruction (%dynamic-call) (wam)
(%%dynamic-procedure-call wam nil))
-(define-instruction (%dynamic-jump) ((wam wam))
+(define-instruction (%dynamic-jump) (wam)
(%%dynamic-procedure-call wam t))
-(define-instruction (%proceed) ((wam wam))
+(define-instruction (%proceed) (wam)
(setf (wam-program-counter wam) ; P <- CP
(wam-continuation-pointer wam)))
-(define-instruction (%allocate) ((wam wam) (n stack-frame-argcount))
+(define-instruction (%allocate) (wam n)
(let ((old-e (wam-environment-pointer wam))
(new-e (wam-stack-top wam)))
(wam-stack-ensure-size wam (+ new-e 4 n))
@@ -568,7 +542,7 @@
(wam-stack-word wam (+ new-e 3)) n ; N
(wam-environment-pointer wam) new-e))) ; E <- new-e
-(define-instruction (%deallocate) ((wam wam))
+(define-instruction (%deallocate) (wam)
(setf (wam-continuation-pointer wam) (wam-stack-frame-cp wam)
(wam-environment-pointer wam) (wam-stack-frame-ce wam)
(wam-cut-pointer wam) (wam-stack-frame-cut wam)))
@@ -578,8 +552,7 @@
(declaim (inline reset-choice-point! restore-registers-from-choice-point!))
-(defun* reset-choice-point! ((wam wam)
- (b backtrack-pointer))
+(defun reset-choice-point! (wam b)
(setf (wam-backtrack-pointer wam) b
;; The book is wrong here: when resetting HB we use the NEW value of B,
@@ -597,14 +570,13 @@
+heap-start+
(wam-stack-choice-h wam b))))
-(defun* restore-registers-from-choice-point! ((wam wam)
- (b backtrack-pointer))
+(defun restore-registers-from-choice-point! (wam b)
(loop :for register :from 0 :below (wam-stack-choice-n wam b)
:for saved-register :from (wam-stack-choice-argument-address wam 0 b)
:do (wam-copy-to-local-register! wam register saved-register)))
-(define-instruction (%try) ((wam wam) (next-clause code-index))
+(define-instruction (%try) (wam next-clause)
(let ((new-b (wam-stack-top wam))
(nargs (wam-number-of-arguments wam)))
(wam-stack-ensure-size wam (+ new-b 8 nargs))
@@ -622,7 +594,7 @@
:for n :from 0 :below nargs ; arg N in the choice point frame
:do (wam-copy-to-stack-choice-argument! wam n i new-b))))
-(define-instruction (%retry) ((wam wam) (next-clause code-index))
+(define-instruction (%retry) (wam next-clause)
(let ((b (wam-backtrack-pointer wam)))
(restore-registers-from-choice-point! wam b)
(unwind-trail! wam (wam-stack-choice-tr wam b) (wam-trail-pointer wam))
@@ -634,7 +606,7 @@
(wam-heap-pointer wam) (wam-stack-choice-h wam b)
(wam-heap-backtrack-pointer wam) (wam-heap-pointer wam))))
-(define-instruction (%trust) ((wam wam))
+(define-instruction (%trust) (wam)
(let* ((b (wam-backtrack-pointer wam))
(old-b (wam-stack-choice-cb wam b)))
(restore-registers-from-choice-point! wam b)
@@ -645,7 +617,7 @@
(wam-heap-pointer wam) (wam-stack-choice-h wam b))
(reset-choice-point! wam old-b)))
-(define-instruction (%cut) ((wam wam))
+(define-instruction (%cut) (wam)
(let ((current-choice-point (wam-backtrack-pointer wam))
(previous-choice-point (wam-stack-frame-cut wam)))
(when (< previous-choice-point current-choice-point)
@@ -657,9 +629,7 @@
(declaim (inline %%match-lisp-object))
-(defun* %%match-lisp-object ((wam wam)
- (object t)
- (address store-index))
+(defun %%match-lisp-object (wam object address)
(cell-typecase (wam (deref wam address) address)
;; If the thing points at a reference (unbound, because we deref'ed) we just
;; bind it.
@@ -676,16 +646,10 @@
(t (backtrack! wam))))
-(define-instruction (%get-lisp-object)
- ((wam wam)
- (object t)
- (register register-index))
+(define-instruction (%get-lisp-object) (wam object register)
(%%match-lisp-object wam object register))
-(define-instruction (%put-lisp-object)
- ((wam wam)
- (object t)
- (register register-index))
+(define-instruction (%put-lisp-object) (wam object register)
(wam-set-local-register! wam register +cell-type-lisp-object+ object))
@@ -693,10 +657,7 @@
(declaim (inline %%match-constant))
-(defun* %%match-constant
- ((wam wam)
- (constant fname)
- (address store-index))
+(defun %%match-constant (wam constant address)
(cell-typecase (wam (deref wam address) address)
(:reference
(wam-set-store-cell! wam address +cell-type-constant+ constant)
@@ -709,21 +670,13 @@
(t (backtrack! wam))))
-(define-instruction (%put-constant)
- ((wam wam)
- (constant fname)
- (register register-index))
+(define-instruction (%put-constant) (wam constant register)
(wam-set-local-register! wam register +cell-type-constant+ constant))
-(define-instruction (%get-constant)
- ((wam wam)
- (constant fname)
- (register register-index))
+(define-instruction (%get-constant) (wam constant register)
(%%match-constant wam constant register))
-(define-instruction (%subterm-constant)
- ((wam wam)
- (constant fname))
+(define-instruction (%subterm-constant) (wam constant)
(ecase (wam-mode wam)
(:read (%%match-constant wam constant (wam-subterm wam)))
(:write (push-new-constant! wam constant)))
@@ -731,7 +684,7 @@
;;;; Running
-(defun* extract-things ((wam wam) (addresses list))
+(defun extract-things (wam addresses)
"Extract the things at the given store addresses.
The things will be returned in the same order as the addresses were given.
@@ -767,7 +720,7 @@
(t (error "What to heck is this?")))))
(mapcar #'recur addresses))))
-(defun* extract-query-results ((wam wam) (vars list))
+(defun extract-query-results (wam vars)
(let* ((addresses (loop :for var :in vars
;; TODO: make this suck less
:for i :from (+ (wam-environment-pointer wam) 4)
@@ -853,7 +806,7 @@
,@(mapcar #'parse-opcode-clause clauses))))
-(defun* run ((wam wam) (done-thunk function) &optional (step *step*))
+(defun run (wam done-thunk &optional (step *step*))
(loop
:with code = (wam-code wam)
:until (or (wam-fail wam) ; failure
@@ -920,11 +873,9 @@
(error "Fell off the end of the program code store."))))
(values))
-(defun* run-query ((wam wam)
- term
- &key
- ((result-function function)
- (lambda (results) (declare (ignore results)))))
+(defun run-query (wam term &key (result-function
+ (lambda (results)
+ (declare (ignore results)))))
"Compile query `term` and run the instructions on the `wam`.
Resets the heap, etc before running.
--- a/src/wam/wam.lisp Sat Jul 16 17:37:17 2016 +0000
+++ b/src/wam/wam.lisp Sat Jul 16 18:23:34 2016 +0000
@@ -104,9 +104,9 @@
(format stream "an wam")))
-(defun* make-wam (&key
- (store-size (megabytes 10))
- (code-size (megabytes 1)))
+(defun make-wam (&key
+ (store-size (megabytes 10))
+ (code-size (megabytes 1)))
(make-wam% :code (allocate-wam-code code-size)
:type-store (allocate-wam-type-store store-size)
:value-store (allocate-wam-value-store store-size)
@@ -155,32 +155,27 @@
wam-copy-store-cell!))
-(defun* wam-store-type ((wam wam) (address store-index))
+(defun wam-store-type (wam address)
"Return the type of the cell at the given address."
(aref (wam-type-store wam) address))
-(defun* wam-store-value ((wam wam) (address store-index))
+(defun wam-store-value (wam address)
"Return the value of the cell at the given address."
(aref (wam-value-store wam) address))
-(defun* wam-set-store-cell! ((wam wam)
- (address store-index)
- (type cell-type)
- (value cell-value))
+(defun wam-set-store-cell! (wam address type value)
(setf (aref (wam-type-store wam) address) type
(aref (wam-value-store wam) address) value))
-(defun* wam-copy-store-cell! ((wam wam)
- (destination store-index)
- (source store-index))
+(defun wam-copy-store-cell! (wam destination source)
(wam-set-store-cell! wam
destination
(wam-store-type wam source)
(wam-store-value wam source)))
-(defun* wam-sanity-check-store-read ((wam wam) (address store-index))
+(defun wam-sanity-check-store-read (wam address)
(declare (ignore wam))
(when (= address +heap-start+)
(error "Cannot read from heap address zero.")))
@@ -189,7 +184,7 @@
(macrolet ((define-unsafe (name return-type)
`(progn
(declaim (inline ,name))
- (defun* ,name ((wam wam) (address store-index))
+ (defun ,name (wam address)
(the ,return-type (aref (wam-value-store wam) address))))))
(define-unsafe %unsafe-null-value (eql 0))
(define-unsafe %unsafe-structure-value store-index)
@@ -303,11 +298,11 @@
(declaim (inline wam-heap-pointer-unset-p wam-heap-push!))
-(defun* wam-heap-pointer-unset-p ((wam wam) (address heap-index))
+(defun wam-heap-pointer-unset-p (wam address)
(declare (ignore wam))
(= address +heap-start+))
-(defun* wam-heap-push! ((wam wam) (type cell-type) (value cell-value))
+(defun wam-heap-push! (wam type value)
"Push the cell onto the WAM heap and increment the heap pointer.
Returns the address it was pushed to.
@@ -329,16 +324,15 @@
(setf wam-trail-value)))
-(defun* wam-trail-pointer ((wam wam))
+(defun wam-trail-pointer (wam)
"Return the current trail pointer of the WAM."
(fill-pointer (wam-trail wam)))
-(defun* (setf wam-trail-pointer) ((new-value trail-index)
- (wam wam))
+(defun (setf wam-trail-pointer) (new-value wam)
(setf (fill-pointer (wam-trail wam)) new-value))
-(defun* wam-trail-push! ((wam wam) (address store-index))
+(defun wam-trail-push! (wam address)
"Push `address` onto the trail.
Returns the address and the trail address it was pushed to.
@@ -349,19 +343,17 @@
(error "WAM trail exhausted.")
(values address (vector-push-extend address trail)))))
-(defun* wam-trail-pop! ((wam wam))
+(defun wam-trail-pop! (wam)
"Pop the top address off the trail and return it."
(vector-pop (wam-trail wam)))
-(defun* wam-trail-value ((wam wam) (address trail-index))
+(defun wam-trail-value (wam address)
;; TODO: can we really not just pop, or is something else gonna do something
;; fucky with the trail?
"Return the element (a heap index) in the WAM trail at `address`."
(aref (wam-trail wam) address))
-(defun* (setf wam-trail-value) ((new-value store-index)
- (wam wam)
- (address trail-index))
+(defun (setf wam-trail-value) (new-value wam address)
(setf (aref (wam-trail wam) address) new-value))
@@ -379,7 +371,7 @@
wam-environment-pointer-unset-p))
-(defun* assert-inside-stack ((wam wam) (address store-index))
+(defun assert-inside-stack (wam address)
(declare (ignorable wam address))
(policy-cond:policy-cond
((>= debug 2)
@@ -395,36 +387,28 @@
(t nil)) ; wew lads
(values))
-(defun* wam-stack-ensure-size ((wam wam) (address stack-index))
+(defun wam-stack-ensure-size (wam address)
"Ensure the WAM stack is large enough to be able to write to `address`."
(assert-inside-stack wam address)
(values))
-(defun* wam-stack-word ((wam wam) (address stack-index))
+(defun wam-stack-word (wam address)
"Return the stack word at the given address."
(assert-inside-stack wam address)
(%unsafe-stack-value wam address))
-(defun* (setf wam-stack-word) ((new-value stack-word)
- (wam wam)
- (address stack-index))
+(defun (setf wam-stack-word) (new-value wam address)
(assert-inside-stack wam address)
(wam-set-store-cell! wam address +cell-type-stack+ new-value))
-(defun* wam-backtrack-pointer-unset-p
- ((wam wam)
- &optional
- ((backtrack-pointer backtrack-pointer)
- (wam-backtrack-pointer wam)))
+(defun wam-backtrack-pointer-unset-p
+ (wam &optional (backtrack-pointer (wam-backtrack-pointer wam)))
(= backtrack-pointer +stack-start+))
-(defun* wam-environment-pointer-unset-p
- ((wam wam)
- &optional
- ((environment-pointer environment-pointer)
- (wam-environment-pointer wam)))
+(defun wam-environment-pointer-unset-p
+ (wam &optional (environment-pointer (wam-environment-pointer wam)))
(= environment-pointer +stack-start+))
@@ -449,68 +433,35 @@
wam-set-stack-frame-argument!))
-(defun* wam-stack-frame-ce
- ((wam wam)
- &optional
- ((e environment-pointer)
- (wam-environment-pointer wam)))
+(defun wam-stack-frame-ce (wam &optional (e (wam-environment-pointer wam)))
(wam-stack-word wam e))
-(defun* wam-stack-frame-cp
- ((wam wam)
- &optional
- ((e environment-pointer)
- (wam-environment-pointer wam)))
+(defun wam-stack-frame-cp (wam &optional (e (wam-environment-pointer wam)))
(wam-stack-word wam (1+ e)))
-(defun* wam-stack-frame-cut
- ((wam wam)
- &optional
- ((e environment-pointer)
- (wam-environment-pointer wam)))
+(defun wam-stack-frame-cut (wam &optional (e (wam-environment-pointer wam)))
(wam-stack-word wam (+ 2 e)))
-(defun* wam-stack-frame-n
- ((wam wam)
- &optional
- ((e environment-pointer)
- (wam-environment-pointer wam)))
+(defun wam-stack-frame-n (wam &optional (e (wam-environment-pointer wam)))
(wam-stack-word wam (+ 3 e)))
-(defun* wam-stack-frame-argument-address
- ((wam wam)
- (n register-index)
- &optional
- ((e environment-pointer)
- (wam-environment-pointer wam)))
+(defun wam-stack-frame-argument-address
+ (wam n &optional (e (wam-environment-pointer wam)))
(+ 4 n e))
-(defun* wam-set-stack-frame-argument!
- ((wam wam)
- (n register-index)
- (type cell-type)
- (value cell-value)
- &optional ((e environment-pointer)
- (wam-environment-pointer wam)))
+(defun wam-set-stack-frame-argument! (wam n type value
+ &optional (e (wam-environment-pointer wam)))
(wam-set-store-cell! wam (wam-stack-frame-argument-address wam n e)
type value))
-(defun* wam-copy-to-stack-frame-argument!
- ((wam wam)
- (n register-index)
- (source store-index)
- &optional ((e environment-pointer)
- (wam-environment-pointer wam)))
+(defun wam-copy-to-stack-frame-argument! (wam n source
+ &optional (e (wam-environment-pointer wam)))
(wam-copy-store-cell! wam (wam-stack-frame-argument-address wam n e)
source))
-(defun* wam-stack-frame-size
- ((wam wam)
- &optional
- ((e environment-pointer)
- (wam-environment-pointer wam)))
+(defun wam-stack-frame-size (wam &optional (e (wam-environment-pointer wam)))
"Return the size of the stack frame starting at environment pointer `e`."
(+ (wam-stack-frame-n wam e) 4))
@@ -548,99 +499,52 @@
wam-copy-to-stack-choice-argument!))
-(defun* wam-stack-choice-n
- ((wam wam)
- &optional
- ((b backtrack-pointer)
- (wam-backtrack-pointer wam)))
+(defun wam-stack-choice-n (wam &optional (b (wam-backtrack-pointer wam)))
(wam-stack-word wam b))
-(defun* wam-stack-choice-ce
- ((wam wam)
- &optional
- ((b backtrack-pointer)
- (wam-backtrack-pointer wam)))
+(defun wam-stack-choice-ce (wam &optional (b (wam-backtrack-pointer wam)))
(wam-stack-word wam (+ b 1)))
-(defun* wam-stack-choice-cp
- ((wam wam)
- &optional
- ((b backtrack-pointer)
- (wam-backtrack-pointer wam)))
+(defun wam-stack-choice-cp (wam &optional (b (wam-backtrack-pointer wam)))
(wam-stack-word wam (+ b 2)))
-(defun* wam-stack-choice-cb
- ((wam wam)
- &optional
- ((b backtrack-pointer)
- (wam-backtrack-pointer wam)))
+(defun wam-stack-choice-cb (wam &optional (b (wam-backtrack-pointer wam)))
(wam-stack-word wam (+ b 3)))
-(defun* wam-stack-choice-bp
- ((wam wam)
- &optional
- ((b backtrack-pointer)
- (wam-backtrack-pointer wam)))
+(defun wam-stack-choice-bp (wam &optional (b (wam-backtrack-pointer wam)))
(wam-stack-word wam (+ b 4)))
-(defun* wam-stack-choice-tr
- ((wam wam)
- &optional
- ((b backtrack-pointer)
- (wam-backtrack-pointer wam)))
+(defun wam-stack-choice-tr (wam &optional (b (wam-backtrack-pointer wam)))
(wam-stack-word wam (+ b 5)))
-(defun* wam-stack-choice-h
- ((wam wam)
- &optional
- ((b backtrack-pointer)
- (wam-backtrack-pointer wam)))
+(defun wam-stack-choice-h (wam &optional (b (wam-backtrack-pointer wam)))
(wam-stack-word wam (+ b 6)))
-(defun* wam-stack-choice-cc
- ((wam wam)
- &optional
- ((b backtrack-pointer)
- (wam-backtrack-pointer wam)))
+(defun wam-stack-choice-cc (wam &optional (b (wam-backtrack-pointer wam)))
(wam-stack-word wam (+ b 7)))
-(defun* wam-stack-choice-argument-address
- ((wam wam)
- (n register-index)
- &optional ((b backtrack-pointer)
- (wam-backtrack-pointer wam)))
+(defun wam-stack-choice-argument-address
+ (wam n &optional (b (wam-backtrack-pointer wam)))
(+ 8 n b))
-(defun* wam-set-stack-choice-argument!
- ((wam wam)
- (n register-index)
- (type cell-type)
- (value cell-value)
- &optional ((b backtrack-pointer)
- (wam-backtrack-pointer wam)))
+(defun wam-set-stack-choice-argument! (wam n type value
+ &optional (b (wam-backtrack-pointer wam)))
(wam-set-store-cell! wam (wam-stack-choice-argument-address wam n b)
type value))
-(defun* wam-copy-to-stack-choice-argument!
- ((wam wam)
- (n register-index)
- (source store-index)
- &optional ((b backtrack-pointer)
- (wam-backtrack-pointer wam)))
+(defun wam-copy-to-stack-choice-argument! (wam n source
+ &optional (b (wam-backtrack-pointer wam)))
(wam-copy-store-cell! wam (wam-stack-choice-argument-address wam n b)
source))
-(defun* wam-stack-choice-size
- ((wam wam)
- &optional ((b backtrack-pointer)
- (wam-backtrack-pointer wam)))
+(defun wam-stack-choice-size (wam &optional (b (wam-backtrack-pointer wam)))
"Return the size of the choice frame starting at backtrack pointer `b`."
(+ (wam-stack-choice-n wam b) 8))
-(defun* wam-stack-top ((wam wam))
+(defun wam-stack-top (wam)
"Return the top of the stack.
This is the first place it's safe to overwrite in the stack.
@@ -662,21 +566,21 @@
;;;; Resetting
-(defun* wam-truncate-heap! ((wam wam))
+(defun wam-truncate-heap! (wam)
;; todo: null out the heap once we're storing live objects
(setf (wam-heap-pointer wam) (1+ +heap-start+)))
-(defun* wam-truncate-trail! ((wam wam))
+(defun wam-truncate-trail! (wam)
(setf (fill-pointer (wam-trail wam)) 0))
-(defun* wam-truncate-unification-stack! ((wam wam))
+(defun wam-truncate-unification-stack! (wam)
(setf (fill-pointer (wam-unification-stack wam)) 0))
-(defun* wam-reset-local-registers! ((wam wam))
+(defun wam-reset-local-registers! (wam)
(fill (wam-type-store wam) +cell-type-null+ :start 0 :end +register-count+)
(fill (wam-value-store wam) 0 :start 0 :end +register-count+))
-(defun* wam-reset! ((wam wam))
+(defun wam-reset! (wam)
(wam-truncate-heap! wam)
(wam-truncate-trail! wam)
(wam-truncate-unification-stack! wam)
@@ -708,7 +612,7 @@
;;;
;;; Each arity's table will be created on-the-fly when it's first needed.
-(defun* retrieve-instruction (code-store (address code-index))
+(defun retrieve-instruction (code-store address)
"Return the full instruction at the given address in the code store."
(make-array (instruction-size (aref code-store address))
:displaced-to code-store
@@ -717,30 +621,24 @@
:element-type 'code-word))
-(defun* wam-code-label ((wam wam) (functor fname) (arity arity))
+(defun wam-code-label (wam functor arity)
(let ((atable (aref (wam-code-labels wam) arity)))
(when atable
(values (gethash functor atable)))))
-(defun* (setf wam-code-label) ((new-value code-index)
- (wam wam)
- (functor fname)
- (arity arity))
+(defun (setf wam-code-label) (new-value wam functor arity)
(setf (gethash functor (aref-or-init (wam-code-labels wam) arity
(make-hash-table :test 'eq)))
new-value))
-(defun* wam-code-label-remove! ((wam wam)
- (functor fname)
- (arity arity))
+(defun wam-code-label-remove! (wam functor arity)
(let ((atable (aref (wam-code-labels wam) arity)))
(when atable
;; todo: remove the table entirely when empty?
(remhash functor atable))))
-(defun* wam-load-query-code! ((wam wam)
- (query-code query-code-holder))
+(defun wam-load-query-code! (wam query-code)
(setf (subseq (wam-code wam) 0) query-code)
(values))
@@ -765,34 +663,34 @@
(predicates (make-hash-table :test 'equal) :type hash-table))
-(defun* wam-logic-pool-release ((wam wam) (frame logic-frame))
+(defun wam-logic-pool-release (wam frame)
(with-slots (start final predicates) frame
(clrhash predicates)
(setf start 0 final nil))
(push frame (wam-logic-pool wam))
(values))
-(defun* wam-logic-pool-request ((wam wam))
+(defun wam-logic-pool-request (wam)
(or (pop (wam-logic-pool wam))
(make-logic-frame)))
-(defun* wam-current-logic-frame ((wam wam))
+(defun wam-current-logic-frame (wam)
(first (wam-logic-stack wam)))
-(defun* wam-logic-stack-empty-p ((wam wam))
+(defun wam-logic-stack-empty-p (wam)
(not (wam-current-logic-frame wam)))
-(defun* wam-logic-open-p ((wam wam))
+(defun wam-logic-open-p (wam)
(let ((frame (wam-current-logic-frame wam)))
(and frame (not (logic-frame-final frame)))))
-(defun* wam-logic-closed-p ((wam wam))
+(defun wam-logic-closed-p (wam)
(not (wam-logic-open-p wam)))
-(defun* wam-push-logic-frame! ((wam wam))
+(defun wam-push-logic-frame! (wam)
(assert (wam-logic-closed-p wam) ()
"Cannot push logic frame unless the logic stack is closed.")
(let ((frame (wam-logic-pool-request wam)))
@@ -815,7 +713,7 @@
(not (logic-frame-final (first logic-stack))))
(error "Cannot pop logic frame.")))))
-(defun* wam-pop-logic-frame! ((wam wam))
+(defun wam-pop-logic-frame! (wam)
(with-slots (logic-stack) wam
(assert-logic-frame-poppable wam)
(let ((frame (pop logic-stack)))
@@ -828,13 +726,13 @@
(values))
-(defun* assert-label-not-already-compiled ((wam wam) clause functor arity)
+(defun assert-label-not-already-compiled (wam clause functor arity)
(assert (not (wam-code-label wam functor arity))
()
"Cannot add clause ~S because its predicate has preexisting compiled code."
clause))
-(defun* wam-logic-frame-add-clause! ((wam wam) clause)
+(defun wam-logic-frame-add-clause! (wam clause)
(assert (wam-logic-open-p wam) ()
"Cannot add clause ~S without an open logic stack frame."
clause)
@@ -848,7 +746,7 @@
(values))
-(defun* wam-finalize-logic-frame! ((wam wam))
+(defun wam-finalize-logic-frame! (wam)
(assert (wam-logic-open-p wam) ()
"There is no logic frame waiting to be finalized.")
(with-slots (predicates final)
@@ -936,50 +834,40 @@
wam-stack-register-address))
-(defun* wam-local-register-address ((wam wam) (register register-index))
+(defun wam-local-register-address (wam register)
(declare (ignore wam))
register)
-(defun* wam-stack-register-address ((wam wam) (register register-index))
+(defun wam-stack-register-address (wam register)
(wam-stack-frame-argument-address wam register))
-(defun* wam-local-register-type ((wam wam) (register register-index))
+(defun wam-local-register-type (wam register)
(wam-store-type wam (wam-local-register-address wam register)))
-(defun* wam-stack-register-type ((wam wam) (register register-index))
+(defun wam-stack-register-type (wam register)
(wam-store-type wam (wam-stack-register-address wam register)))
-(defun* wam-local-register-value ((wam wam) (register register-index))
+(defun wam-local-register-value (wam register)
(wam-store-value wam (wam-local-register-address wam register)))
-(defun* wam-stack-register-value ((wam wam) (register register-index))
+(defun wam-stack-register-value (wam register)
(wam-store-value wam (wam-stack-register-address wam register)))
-(defun* wam-set-local-register! ((wam wam)
- (address register-index)
- (type cell-type)
- (value cell-value))
+(defun wam-set-local-register! (wam address type value)
(wam-set-store-cell! wam (wam-local-register-address wam address)
type value))
-(defun* wam-set-stack-register! ((wam wam)
- (address register-index)
- (type cell-type)
- (value cell-value))
+(defun wam-set-stack-register! (wam address type value)
(wam-set-stack-frame-argument! wam address type value))
-(defun* wam-copy-to-local-register! ((wam wam)
- (destination register-index)
- (source store-index))
+(defun wam-copy-to-local-register! (wam destination source)
(wam-copy-store-cell! wam (wam-local-register-address wam destination) source))
-(defun* wam-copy-to-stack-register! ((wam wam)
- (destination register-index)
- (source store-index))
+(defun wam-copy-to-stack-register! (wam destination source)
(wam-copy-store-cell! wam (wam-stack-register-address wam destination) source))
@@ -989,15 +877,12 @@
wam-unification-stack-empty-p))
-(defun* wam-unification-stack-push!
- ((wam wam)
- (address1 store-index)
- (address2 store-index))
+(defun wam-unification-stack-push! (wam address1 address2)
(vector-push-extend address1 (wam-unification-stack wam))
(vector-push-extend address2 (wam-unification-stack wam)))
-(defun* wam-unification-stack-pop! ((wam wam))
+(defun wam-unification-stack-pop! (wam)
(vector-pop (wam-unification-stack wam)))
-(defun* wam-unification-stack-empty-p ((wam wam))
+(defun wam-unification-stack-empty-p (wam)
(zerop (length (wam-unification-stack wam))))