--- a/examples/ggp-paip-interpreted.lisp Sat Jul 16 13:47:55 2016 +0000
+++ b/examples/ggp-paip-interpreted.lisp Sat Jul 16 17:37:17 2016 +0000
@@ -8,34 +8,28 @@
(defun* queue-contents ((q queue))
- (:returns list)
(cdr q))
(defun* make-queue ()
- (:returns queue)
(let ((q (cons nil nil)))
(setf (car q) q)))
(defun* enqueue ((item t) (q queue))
- (:returns queue)
(setf (car q)
(setf (rest (car q))
(cons item nil)))
q)
(defun* dequeue ((q queue))
- (:returns t)
(prog1
(pop (cdr q))
(if (null (cdr q))
(setf (car q) q))))
(defun* queue-empty-p ((q queue))
- (:returns boolean)
(null (queue-contents q)))
(defun* queue-append ((q queue) (l list))
- (:returns queue)
(when l
(setf (car q)
(last (setf (rest (car q))
--- a/src/circle.lisp Sat Jul 16 13:47:55 2016 +0000
+++ b/src/circle.lisp Sat Jul 16 17:37:17 2016 +0000
@@ -58,7 +58,6 @@
(defun* make-empty-circle ()
- (:returns circle)
"Create an empty circle.
It will still contain a sentinel.
@@ -71,7 +70,6 @@
(defun* make-circle-with ((list list))
"Create a circle whose nodes contain the values in `list`."
- (:returns circle)
(let ((sentinel (make-empty-circle)))
(loop :with prev = sentinel
:for value :in list
@@ -94,26 +92,22 @@
(defun* circle-sentinel-p ((circle circle))
- (:returns boolean)
"Return whether this circle node is the sentinel."
(eq (circle-value circle) +circle-sentinel+))
(defun* circle-empty-p ((circle circle))
- (:returns boolean)
"Return whether this circle is empty."
(and (circle-sentinel-p circle)
(eql circle (circle-next circle))))
(defun* circle-rotate ((circle circle) (n integer))
- (:returns circle)
(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))
- (:returns circle)
(when (not (circle-sentinel-p circle))
(error "Can only call circle-nth on the sentinel."))
(circle-rotate circle
@@ -179,13 +173,11 @@
(defun* circle-forward ((circle circle))
- (:returns (or circle null))
(let ((next (circle-next circle)))
(when (not (circle-sentinel-p next))
next)))
(defun* circle-backward ((circle circle))
- (:returns (or circle null))
(let ((prev (circle-prev circle)))
(when (not (circle-sentinel-p prev))
prev)))
@@ -200,20 +192,17 @@
(circle-tie l r)))
(defun* circle-backward-remove ((circle circle))
- (:returns (or circle null))
(prog1
(circle-backward circle)
(circle-remove circle)))
(defun* circle-forward-remove ((circle circle))
- (:returns (or circle null))
(prog1
(circle-forward circle)
(circle-remove circle)))
(defun* circle-replace ((circle circle) value)
- (:returns circle)
(when (circle-sentinel-p circle)
(error "Cannot replace sentinel."))
;; L new R
@@ -222,13 +211,11 @@
(make-circle-between l value r)))
(defun* circle-backward-replace ((circle circle) value)
- (:returns (or circle null))
(prog1
(circle-backward circle)
(circle-replace circle value)))
(defun* circle-forward-replace ((circle circle) value)
- (:returns (or circle null))
(prog1
(circle-forward circle)
(circle-replace circle value)))
@@ -248,20 +235,17 @@
(circle-tie (circle-prev new) r)))))
(defun* circle-backward-splice ((circle circle) values)
- (:returns (or circle null))
(prog1
(circle-backward circle)
(circle-splice circle values)))
(defun* circle-forward-splice ((circle circle) values)
- (:returns (or circle null))
(prog1
(circle-forward circle)
(circle-splice circle values)))
(defun* circle-to-list ((circle circle) &optional include-sentinel-p)
- (:returns list)
(loop
:with node = circle
:when (or include-sentinel-p
--- a/src/paip-compiled.lisp Sat Jul 16 13:47:55 2016 +0000
+++ b/src/paip-compiled.lisp Sat Jul 16 17:37:17 2016 +0000
@@ -59,7 +59,6 @@
(write var :stream stream)))
(defun* bound-p ((var var))
- (:returns boolean)
"Return whether the given variable has been bound."
(not (eq (var-binding var) unbound)))
@@ -76,7 +75,6 @@
"The trail of variable bindings performed so far.")
(defun* set-binding! ((var var) value)
- (:returns (eql t))
"Set `var`'s binding to `value` after saving it in the trail.
Always returns `t` (success).
@@ -88,7 +86,6 @@
t)
(defun* undo-bindings! ((old-trail integer))
- (:returns :void)
"Undo all bindings back to a given point in the trail.
The point is specified by giving the desired fill pointer.
@@ -101,7 +98,6 @@
;;;; Unification
(defun* unify! (x y)
- (:returns boolean)
"Destructively unify two expressions, returning whether it was successful.
Any variables in `x` and `y` may have their bindings set.
@@ -156,7 +152,6 @@
(defun* relation-arity ((relation relation))
- (:returns non-negative-integer)
"Return the number of arguments of the given relation.
For example: `(relation-arity '(likes sally cats))` => `2`
@@ -165,7 +160,6 @@
(length (relation-arguments relation)))
(defun* relation-arguments ((relation relation))
- (:returns list)
"Return the arguments of the given relation.
For example:
@@ -193,14 +187,12 @@
clauses)))))))
(defun* make-parameters ((arity non-negative-integer))
- (:returns (trivial-types:proper-list symbol))
"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))
- (:returns symbol)
"Returns (and interns) the symbol with the Prolog-style name symbol/arity."
(values (interned-symbol symbol '/ arity)))
--- a/src/paip.lisp Sat Jul 16 13:47:55 2016 +0000
+++ b/src/paip.lisp Sat Jul 16 17:37:17 2016 +0000
@@ -25,7 +25,6 @@
;;;; Unification
(defun* variable-p (term)
- (:returns boolean)
"Return whether the given term is a logic variable."
(and (symbolp term)
(equal (char (symbol-name term) 0)
@@ -34,18 +33,15 @@
(defun* get-binding ((variable logic-variable)
(bindings binding-list))
- (:returns (or binding null))
"Return the binding (var . val) for the given variable, or nil."
(assoc variable bindings))
(defun* has-binding ((variable logic-variable)
(bindings binding-list))
- (:returns boolean)
(not (null (get-binding variable bindings))))
(defun* binding-variable ((binding binding))
- (:returns logic-variable)
"Return the variable part of a binding."
(car binding))
@@ -62,7 +58,6 @@
(defun* extend-bindings ((variable logic-variable)
(value t)
(bindings binding-list))
- (:returns binding-list)
"Add a binding (var . val) to the binding list (nondestructively)."
(cons (cons variable value)
(if (and (equal bindings no-bindings))
@@ -73,7 +68,6 @@
(defun* check-occurs ((variable logic-variable)
(target t)
(bindings binding-list))
- (:returns boolean)
"Check whether the variable occurs somewhere in the target.
Takes the bindings into account. This is expensive.
--- a/src/utils.lisp Sat Jul 16 13:47:55 2016 +0000
+++ b/src/utils.lisp Sat Jul 16 17:37:17 2016 +0000
@@ -159,15 +159,12 @@
(defun* make-queue ()
- (:returns queue)
(make-queue%))
(defun* queue-empty-p ((q queue))
- (:returns boolean)
(zerop (queue-size q)))
(defun* enqueue ((item t) (q queue))
- (:returns fixnum)
(let ((cell (cons item nil)))
(setf (queue-last q)
(if (queue-empty-p q)
@@ -176,13 +173,11 @@
(incf (queue-size q)))
(defun* dequeue ((q queue))
- (:returns t)
(when (zerop (decf (queue-size q)))
(setf (queue-last q) nil))
(pop (queue-contents q)))
(defun* queue-append ((q queue) (l list))
- (:returns fixnum) ; todo make a structure sharing version of this
(loop :for item :in l
:for size = (enqueue item q)
:finally (return size)))
@@ -234,9 +229,8 @@
:test (lambda (x y) (declare (ignore x y)) t)) ; what could go wrong
(declaim (inline ,name))
(defun* ,name ((,key ,key-type))
- (:returns ,value-type)
,documentation
- (aref ,table ,key))))))
+ (the ,value-type (aref ,table ,key)))))))
;;;; ecase/tree
--- a/src/wam/bytecode.lisp Sat Jul 16 13:47:55 2016 +0000
+++ b/src/wam/bytecode.lisp Sat Jul 16 17:37:17 2016 +0000
@@ -3,7 +3,6 @@
;;;; Opcodes
(defun* opcode-name ((opcode opcode))
- (:returns string)
(eswitch (opcode)
(+opcode-noop+ "NOOP")
@@ -49,7 +48,6 @@
(+opcode-put-lisp-object+ "PUT-LISP-OBJECT")))
(defun* opcode-short-name ((opcode opcode))
- (:returns string)
(eswitch (opcode)
(+opcode-noop+ "NOOP")
--- a/src/wam/compiler/0-data.lisp Sat Jul 16 13:47:55 2016 +0000
+++ b/src/wam/compiler/0-data.lisp Sat Jul 16 17:37:17 2016 +0000
@@ -13,7 +13,6 @@
(declaim (inline variablep))
(defun* variablep (term)
- (:returns boolean)
(and (symbolp term)
(char= (char (symbol-name term) 0) #\?)))
@@ -46,16 +45,13 @@
(defun* make-temporary-register ((number register-number) (arity arity))
- (:returns register)
(make-register (if (< number arity) :argument :local)
number))
(defun* make-permanent-register ((number register-number))
- (:returns register)
(make-register :permanent number))
(defun* make-anonymous-register ()
- (:returns register)
(make-register :anonymous 0))
@@ -76,24 +72,19 @@
(defun* register-argument-p ((register register))
- (:returns boolean)
(eq (register-type register) :argument))
(defun* register-temporary-p ((register register))
- (:returns boolean)
(and (member (register-type register) '(:argument :local)) t))
(defun* register-permanent-p ((register register))
- (:returns boolean)
(eq (register-type register) :permanent))
(defun* register-anonymous-p ((register register))
- (:returns boolean)
(eq (register-type register) :anonymous))
(defun* register= ((r1 register) (r2 register))
- (:returns boolean)
(and (eq (register-type r1)
(register-type r2))
(= (register-number r1)
@@ -182,7 +173,6 @@
(defun* determine-clause-properties (head body)
- (:returns clause-properties)
(let* ((clause
(cons head body))
(permanent-vars
--- a/src/wam/compiler/1-parsing.lisp Sat Jul 16 13:47:55 2016 +0000
+++ b/src/wam/compiler/1-parsing.lisp Sat Jul 16 17:37:17 2016 +0000
@@ -49,7 +49,6 @@
(defgeneric* node-children (node)
- (:returns list)
"Return the children of the given node.
Presumably these will need to be traversed when allocating registers.")
@@ -68,7 +67,6 @@
(defun* nil-node-p ((node node))
- (:returns boolean)
"Return whether the given node is the magic nil/0 constant."
(and (typep node 'structure-node)
(eql (node-functor node) nil)
@@ -148,7 +146,6 @@
(defun* parse-list ((contents list))
- (:returns node)
(if contents
(make-list-node :head (parse (car contents))
:tail (parse-list (cdr contents)))
@@ -157,7 +154,6 @@
:arguments ())))
(defun* parse-list* ((contents list))
- (:returns node)
(destructuring-bind (next . remaining) contents
(if (null remaining)
(parse next)
@@ -165,7 +161,6 @@
:tail (parse-list* remaining)))))
(defun* parse (term &optional top-level-argument)
- (:returns node)
(cond
((variablep term)
(if top-level-argument
@@ -190,7 +185,6 @@
(t (error "Cannot parse term ~S into a Prolog term." term))))
(defun* parse-top-level (term)
- (:returns top-level-node)
(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 13:47:55 2016 +0000
+++ b/src/wam/compiler/2-register-allocation.lisp Sat Jul 16 17:37:17 2016 +0000
@@ -150,7 +150,6 @@
(defun* find-variable ((state allocation-state) (variable symbol))
- (:returns (or register null))
"Return the register that already contains this variable, or `nil` otherwise."
(or (when-let (r (position variable
(queue-contents
@@ -162,7 +161,6 @@
nil))
(defun* store-variable ((state allocation-state) (variable symbol))
- (:returns register)
"Assign `variable` to the next available local register.
It is assumed that `variable` is not already assigned to another register
@@ -177,7 +175,6 @@
(1- (enqueue variable (allocation-state-local-registers state)))))
(defun* ensure-variable ((state allocation-state) (variable symbol))
- (:returns register)
(or (find-variable state variable)
(store-variable state variable)))
@@ -189,19 +186,16 @@
(defun* variable-anonymous-p ((state allocation-state) (variable symbol))
- (:returns boolean)
"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))
- (:returns register)
(if (variable-anonymous-p state variable)
(make-anonymous-register)
(ensure-variable state variable)))
(defun* allocate-nonvariable-register ((state allocation-state))
- (:returns register)
"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
--- a/src/wam/compiler/3-flattening.lisp Sat Jul 16 13:47:55 2016 +0000
+++ b/src/wam/compiler/3-flattening.lisp Sat Jul 16 17:37:17 2016 +0000
@@ -80,8 +80,7 @@
(lisp-object-to-string (assignment-object assignment)))))
-(defgeneric* node-flatten (node)
- (:returns (or null register-assignment)))
+(defgeneric* node-flatten (node))
(defmethod node-flatten (node)
nil)
@@ -111,7 +110,6 @@
(defun* flatten-breadth-first ((tree top-level-node))
- (:returns list)
(let ((results nil))
(recursively ((node tree))
(when-let (assignment (node-flatten node))
@@ -120,7 +118,6 @@
(nreverse results)))
(defun* flatten-depth-first-post-order ((tree top-level-node))
- (:returns list)
(let ((results nil))
(recursively ((node tree))
(mapcar #'recur (node-children node))
@@ -130,11 +127,9 @@
(defun* flatten-query ((tree top-level-node))
- (:returns list)
(flatten-depth-first-post-order tree))
(defun* flatten-program ((tree top-level-node))
- (:returns list)
(flatten-breadth-first tree))
--- a/src/wam/compiler/4-tokenization.lisp Sat Jul 16 13:47:55 2016 +0000
+++ b/src/wam/compiler/4-tokenization.lisp Sat Jul 16 17:37:17 2016 +0000
@@ -49,7 +49,6 @@
(defun* make-register-token ((register register))
- (:returns register-token)
(values (make-instance 'register-token :register register)))
@@ -97,7 +96,6 @@
(defgeneric* tokenize-assignment ((assignment register-assignment))
- (:returns list)
"Tokenize `assignment` into a flat list of tokens.")
(defmethod tokenize-assignment ((assignment structure-assignment))
@@ -123,13 +121,11 @@
:object (assignment-object assignment))))
(defun* tokenize-assignments ((assignments list))
- (:returns list)
"Tokenize a flattened set of register assignments into a stream."
(mapcan #'tokenize-assignment assignments))
(defun* tokenize-program-term (term (clause-props clause-properties))
- (:returns list)
"Tokenize `term` as a program term, returning its tokens."
(let ((tree (parse-top-level term)))
(allocate-registers tree clause-props :nead t)
@@ -138,7 +134,6 @@
(defun* tokenize-query-term (term
(clause-props clause-properties)
&key in-nead is-tail)
- (:returns list)
"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 13:47:55 2016 +0000
+++ b/src/wam/compiler/5-precompilation.lisp Sat Jul 16 17:37:17 2016 +0000
@@ -105,7 +105,6 @@
(defun* find-opcode-register ((first-seen boolean) (register register))
- (:returns keyword)
(let ((register-variant (when register
(ecase (register-type register)
((:local :argument) :local)
@@ -122,19 +121,16 @@
(:void :subterm-void)))))
(defun* find-opcode-list ((mode keyword))
- (:returns keyword)
(ecase mode
(:program :get-list)
(:query :put-list)))
(defun* find-opcode-lisp-object ((mode keyword))
- (:returns keyword)
(ecase mode
(:program :get-lisp-object)
(:query :put-lisp-object)))
(defun* find-opcode-structure ((mode keyword))
- (:returns keyword)
(ecase mode
(:program :get-structure)
(:query :put-structure)))
@@ -142,7 +138,6 @@
(defun* find-opcode-argument ((first-seen boolean)
(mode keyword)
(register register))
- (:returns keyword)
(let ((register-variant (ecase (register-type register)
((:local :argument) :local)
((:permanent) :stack))))
@@ -164,7 +159,6 @@
(defun* precompile-tokens ((head-tokens list) (body-tokens list))
- (:returns circle)
"Generate a series of machine instructions from a stream of head and body
tokens.
@@ -277,7 +271,6 @@
(defun* precompile-clause (head body)
- (:returns (values circle clause-properties))
"Precompile the clause.
`head` should be the head of the clause for program clauses, or `nil` for
@@ -356,7 +349,6 @@
(defun* precompile-query ((query list))
- (:returns (values circle list))
"Compile `query`, returning the instructions and permanent variables.
`query` should be a list of goal terms.
@@ -369,7 +361,6 @@
(defun* find-predicate ((clause cons))
- (:returns (values t arity))
"Return the functor and arity of the predicate of `clause`."
;; ( (f ?x ?y) | head ||| clause
;; (foo ?x) || body |||
--- a/src/wam/compiler/6-optimization.lisp Sat Jul 16 13:47:55 2016 +0000
+++ b/src/wam/compiler/6-optimization.lisp Sat Jul 16 17:37:17 2016 +0000
@@ -61,7 +61,6 @@
(return (circle-backward-remove node))))
(defun* optimize-constants ((instructions circle))
- (:returns circle)
;; From the book and the erratum, there are four optimizations we can do for
;; constants (0-arity structures).
@@ -86,7 +85,6 @@
(defun* optimize-void-runs ((instructions circle))
- (:returns circle)
;; We can optimize runs of N (:[unify/set]-void 1) instructions into a single
;; one that does all N at once.
(loop
--- a/src/wam/compiler/7-rendering.lisp Sat Jul 16 13:47:55 2016 +0000
+++ b/src/wam/compiler/7-rendering.lisp Sat Jul 16 17:37:17 2016 +0000
@@ -33,7 +33,6 @@
Returns how many words were pushed.
"
- (:returns instruction-size)
(check-instruction opcode arguments)
(setf (aref store address) opcode
(subseq store (1+ address)) arguments)
@@ -41,7 +40,6 @@
(defun* render-opcode ((opcode-designator keyword))
- (:returns opcode)
(ecase opcode-designator
(:get-structure +opcode-get-structure+)
(:get-variable-local +opcode-get-variable-local+)
@@ -79,7 +77,6 @@
(:cut +opcode-cut+)))
(defun* render-argument (argument)
- (:returns code-word)
(cond
;; Ugly choice point args that'll be filled later...
((eq +choice-point-placeholder+ argument) 0)
--- a/src/wam/vm.lisp Sat Jul 16 13:47:55 2016 +0000
+++ b/src/wam/vm.lisp Sat Jul 16 17:37:17 2016 +0000
@@ -10,12 +10,10 @@
(defun* push-unbound-reference! ((wam wam))
- (:returns heap-index)
"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))
- (:returns heap-index)
"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
@@ -25,7 +23,6 @@
(wam-heap-push! wam +cell-type-structure+ (1+ (wam-heap-pointer wam))))
(defun* push-new-list! ((wam wam))
- (:returns heap-index)
"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
@@ -35,32 +32,27 @@
(wam-heap-push! wam +cell-type-list+ (1+ (wam-heap-pointer wam))))
(defun* push-new-functor! ((wam wam) (functor fname) (arity arity))
- (:returns heap-index)
"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))
- (:returns heap-index)
"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))
- (:returns boolean)
"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))
- (:returns boolean)
"Return whether the two constant cell values unify."
(eq c1 c2))
(defun* lisp-objects-match-p ((o1 t) (o2 t))
- (:returns boolean)
"Return whether the two lisp object cells unify."
(eql o1 o2))
@@ -123,7 +115,6 @@
(decf tr))))))
(defun* deref ((wam wam) (address store-index))
- (:returns store-index)
"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
@@ -741,7 +732,6 @@
;;;; Running
(defun* extract-things ((wam wam) (addresses list))
- (:returns list)
"Extract the things at the given store addresses.
The things will be returned in the same order as the addresses were given.
@@ -778,7 +768,6 @@
(mapcar #'recur addresses))))
(defun* extract-query-results ((wam wam) (vars list))
- (:returns list)
(let* ((addresses (loop :for var :in vars
;; TODO: make this suck less
:for i :from (+ (wam-environment-pointer wam) 4)
--- a/src/wam/wam.lisp Sat Jul 16 13:47:55 2016 +0000
+++ b/src/wam/wam.lisp Sat Jul 16 17:37:17 2016 +0000
@@ -107,7 +107,6 @@
(defun* make-wam (&key
(store-size (megabytes 10))
(code-size (megabytes 1)))
- (:returns wam)
(make-wam% :code (allocate-wam-code code-size)
:type-store (allocate-wam-type-store store-size)
:value-store (allocate-wam-value-store store-size)
@@ -157,12 +156,10 @@
(defun* wam-store-type ((wam wam) (address store-index))
- (:returns cell-type)
"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))
- (:returns cell-value)
"Return the value of the cell at the given address."
(aref (wam-value-store wam) address))
@@ -193,8 +190,7 @@
`(progn
(declaim (inline ,name))
(defun* ,name ((wam wam) (address store-index))
- (:returns ,return-type)
- (aref (wam-value-store 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)
(define-unsafe %unsafe-reference-value store-index)
@@ -308,12 +304,10 @@
(defun* wam-heap-pointer-unset-p ((wam wam) (address heap-index))
- (:returns boolean)
(declare (ignore wam))
(= address +heap-start+))
(defun* wam-heap-push! ((wam wam) (type cell-type) (value cell-value))
- (:returns heap-index)
"Push the cell onto the WAM heap and increment the heap pointer.
Returns the address it was pushed to.
@@ -336,7 +330,6 @@
(defun* wam-trail-pointer ((wam wam))
- (:returns trail-index)
"Return the current trail pointer of the WAM."
(fill-pointer (wam-trail wam)))
@@ -346,7 +339,6 @@
(defun* wam-trail-push! ((wam wam) (address store-index))
- (:returns (values store-index trail-index))
"Push `address` onto the trail.
Returns the address and the trail address it was pushed to.
@@ -358,14 +350,12 @@
(values address (vector-push-extend address trail)))))
(defun* wam-trail-pop! ((wam wam))
- (:returns store-index)
"Pop the top address off the trail and return it."
(vector-pop (wam-trail wam)))
(defun* wam-trail-value ((wam wam) (address trail-index))
;; TODO: can we really not just pop, or is something else gonna do something
;; fucky with the trail?
- (:returns store-index)
"Return the element (a heap index) in the WAM trail at `address`."
(aref (wam-trail wam) address))
@@ -390,7 +380,6 @@
(defun* assert-inside-stack ((wam wam) (address store-index))
- (:returns :void)
(declare (ignorable wam address))
(policy-cond:policy-cond
((>= debug 2)
@@ -407,14 +396,12 @@
(values))
(defun* wam-stack-ensure-size ((wam wam) (address stack-index))
- (:returns :void)
"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))
- (:returns stack-word)
"Return the stack word at the given address."
(assert-inside-stack wam address)
(%unsafe-stack-value wam address))
@@ -431,7 +418,6 @@
&optional
((backtrack-pointer backtrack-pointer)
(wam-backtrack-pointer wam)))
- (:returns boolean)
(= backtrack-pointer +stack-start+))
(defun* wam-environment-pointer-unset-p
@@ -439,7 +425,6 @@
&optional
((environment-pointer environment-pointer)
(wam-environment-pointer wam)))
- (:returns boolean)
(= environment-pointer +stack-start+))
@@ -469,7 +454,6 @@
&optional
((e environment-pointer)
(wam-environment-pointer wam)))
- (:returns environment-pointer)
(wam-stack-word wam e))
(defun* wam-stack-frame-cp
@@ -477,7 +461,6 @@
&optional
((e environment-pointer)
(wam-environment-pointer wam)))
- (:returns continuation-pointer)
(wam-stack-word wam (1+ e)))
(defun* wam-stack-frame-cut
@@ -485,7 +468,6 @@
&optional
((e environment-pointer)
(wam-environment-pointer wam)))
- (:returns backtrack-pointer)
(wam-stack-word wam (+ 2 e)))
(defun* wam-stack-frame-n
@@ -493,7 +475,6 @@
&optional
((e environment-pointer)
(wam-environment-pointer wam)))
- (:returns stack-frame-argcount)
(wam-stack-word wam (+ 3 e)))
@@ -503,7 +484,6 @@
&optional
((e environment-pointer)
(wam-environment-pointer wam)))
- (:returns stack-index)
(+ 4 n e))
(defun* wam-set-stack-frame-argument!
@@ -531,7 +511,6 @@
&optional
((e environment-pointer)
(wam-environment-pointer wam)))
- (:returns stack-frame-size)
"Return the size of the stack frame starting at environment pointer `e`."
(+ (wam-stack-frame-n wam e) 4))
@@ -574,7 +553,6 @@
&optional
((b backtrack-pointer)
(wam-backtrack-pointer wam)))
- (:returns arity)
(wam-stack-word wam b))
(defun* wam-stack-choice-ce
@@ -582,7 +560,6 @@
&optional
((b backtrack-pointer)
(wam-backtrack-pointer wam)))
- (:returns environment-pointer)
(wam-stack-word wam (+ b 1)))
(defun* wam-stack-choice-cp
@@ -590,7 +567,6 @@
&optional
((b backtrack-pointer)
(wam-backtrack-pointer wam)))
- (:returns continuation-pointer)
(wam-stack-word wam (+ b 2)))
(defun* wam-stack-choice-cb
@@ -598,7 +574,6 @@
&optional
((b backtrack-pointer)
(wam-backtrack-pointer wam)))
- (:returns backtrack-pointer)
(wam-stack-word wam (+ b 3)))
(defun* wam-stack-choice-bp
@@ -606,7 +581,6 @@
&optional
((b backtrack-pointer)
(wam-backtrack-pointer wam)))
- (:returns continuation-pointer)
(wam-stack-word wam (+ b 4)))
(defun* wam-stack-choice-tr
@@ -614,7 +588,6 @@
&optional
((b backtrack-pointer)
(wam-backtrack-pointer wam)))
- (:returns trail-index)
(wam-stack-word wam (+ b 5)))
(defun* wam-stack-choice-h
@@ -622,7 +595,6 @@
&optional
((b backtrack-pointer)
(wam-backtrack-pointer wam)))
- (:returns heap-index)
(wam-stack-word wam (+ b 6)))
(defun* wam-stack-choice-cc
@@ -630,7 +602,6 @@
&optional
((b backtrack-pointer)
(wam-backtrack-pointer wam)))
- (:returns backtrack-pointer)
(wam-stack-word wam (+ b 7)))
@@ -639,7 +610,6 @@
(n register-index)
&optional ((b backtrack-pointer)
(wam-backtrack-pointer wam)))
- (:returns stack-index)
(+ 8 n b))
(defun* wam-set-stack-choice-argument!
@@ -666,13 +636,11 @@
((wam wam)
&optional ((b backtrack-pointer)
(wam-backtrack-pointer wam)))
- (:returns stack-choice-size)
"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))
- (:returns stack-index)
"Return the top of the stack.
This is the first place it's safe to overwrite in the stack.
@@ -750,7 +718,6 @@
(defun* wam-code-label ((wam wam) (functor fname) (arity arity))
- (:returns (or null code-index))
(let ((atable (aref (wam-code-labels wam) arity)))
(when atable
(values (gethash functor atable)))))
@@ -774,7 +741,6 @@
(defun* wam-load-query-code! ((wam wam)
(query-code query-code-holder))
- (:returns :void)
(setf (subseq (wam-code wam) 0) query-code)
(values))
@@ -800,7 +766,6 @@
(defun* wam-logic-pool-release ((wam wam) (frame logic-frame))
- (:returns :void)
(with-slots (start final predicates) frame
(clrhash predicates)
(setf start 0 final nil))
@@ -808,32 +773,26 @@
(values))
(defun* wam-logic-pool-request ((wam wam))
- (:returns logic-frame)
(or (pop (wam-logic-pool wam))
(make-logic-frame)))
(defun* wam-current-logic-frame ((wam wam))
- (:returns (or null logic-frame))
(first (wam-logic-stack wam)))
(defun* wam-logic-stack-empty-p ((wam wam))
- (:returns boolean)
(not (wam-current-logic-frame wam)))
(defun* wam-logic-open-p ((wam wam))
- (:returns boolean)
(let ((frame (wam-current-logic-frame wam)))
(and frame (not (logic-frame-final frame)))))
(defun* wam-logic-closed-p ((wam wam))
- (:returns boolean)
(not (wam-logic-open-p wam)))
(defun* wam-push-logic-frame! ((wam wam))
- (:returns :void)
(assert (wam-logic-closed-p wam) ()
"Cannot push logic frame unless the logic stack is closed.")
(let ((frame (wam-logic-pool-request wam)))
@@ -857,7 +816,6 @@
(error "Cannot pop logic frame.")))))
(defun* wam-pop-logic-frame! ((wam wam))
- (:returns :void)
(with-slots (logic-stack) wam
(assert-logic-frame-poppable wam)
(let ((frame (pop logic-stack)))
@@ -979,30 +937,24 @@
(defun* wam-local-register-address ((wam wam) (register register-index))
- (:returns store-index)
(declare (ignore wam))
register)
(defun* wam-stack-register-address ((wam wam) (register register-index))
- (:returns store-index)
(wam-stack-frame-argument-address wam register))
(defun* wam-local-register-type ((wam wam) (register register-index))
- (:returns cell-type)
(wam-store-type wam (wam-local-register-address wam register)))
(defun* wam-stack-register-type ((wam wam) (register register-index))
- (:returns cell-type)
(wam-store-type wam (wam-stack-register-address wam register)))
(defun* wam-local-register-value ((wam wam) (register register-index))
- (:returns cell-value)
(wam-store-value wam (wam-local-register-address wam register)))
(defun* wam-stack-register-value ((wam wam) (register register-index))
- (:returns cell-value)
(wam-store-value wam (wam-stack-register-address wam register)))
@@ -1045,9 +997,7 @@
(vector-push-extend address2 (wam-unification-stack wam)))
(defun* wam-unification-stack-pop! ((wam wam))
- (:returns store-index)
(vector-pop (wam-unification-stack wam)))
(defun* wam-unification-stack-empty-p ((wam wam))
- (:returns boolean)
(zerop (length (wam-unification-stack wam))))