--- a/package.lisp Fri May 13 20:00:52 2016 +0000
+++ b/package.lisp Sat May 14 18:52:14 2016 +0000
@@ -20,7 +20,9 @@
#:make-empty-circle
#:circle-to-list
#:circle-prepend
+ #:circle-prepend-circle
#:circle-append
+ #:circle-append-circle
#:circle-forward
#:circle-backward
#:circle-value
--- a/src/circle.lisp Fri May 13 20:00:52 2016 +0000
+++ b/src/circle.lisp Sat May 14 18:52:14 2016 +0000
@@ -100,9 +100,9 @@
(defun* circle-rotate ((circle circle) (n integer))
(:returns circle)
(cond
- ((zerop n) circle)
((> n 0) (circle-rotate (circle-next circle) (1- n)))
- ((< n 0) (circle-rotate (circle-prev circle) (1+ n)))))
+ ((< n 0) (circle-rotate (circle-prev circle) (1+ n)))
+ (t circle)))
(defun* circle-nth ((circle circle) (n integer))
(:returns circle)
@@ -151,32 +151,43 @@
(circle-insert-before circle value))
-(defun* circle-prepend ((circle circle) values)
+(defun* circle-prepend-circle ((circle circle) (other circle))
(:returns :void)
(assert (circle-sentinel-p circle) ()
"Can only prepend to the sentinel.")
+ (assert (circle-sentinel-p other) ()
+ "Can only prepend from the sentinel.")
;; S new-first ... new-last R
- (if (null values)
- circle
- (let ((s circle)
- (r (circle-next circle))
- (new (make-circle-with values)))
- (circle-tie s (circle-next new))
- (circle-tie (circle-prev new) r)))
+ (let ((s circle)
+ (r (circle-next circle)))
+ (circle-tie s (circle-next other))
+ (circle-tie (circle-prev other) r))
+ (values))
+
+(defun* circle-prepend ((circle circle) values)
+ (:returns :void)
+ (unless (null values)
+ (circle-prepend-circle circle (make-circle-with values)))
+ (values))
+
+
+(defun* circle-append-circle ((circle circle) (other circle))
+ (:returns :void)
+ (assert (circle-sentinel-p circle) ()
+ "Can only append to the sentinel.")
+ (assert (circle-sentinel-p other) ()
+ "Can only append from the sentinel.")
+ ;; L new-first ... new-last S
+ (let ((s circle)
+ (l (circle-prev circle)))
+ (circle-tie l (circle-next other))
+ (circle-tie (circle-prev other) s))
(values))
(defun* circle-append ((circle circle) values)
(:returns :void)
- (assert (circle-sentinel-p circle) ()
- "Can only prepend to the sentinel.")
- ;; L new-first ... new-last S
- (if (null values)
- circle
- (let ((s circle)
- (l (circle-prev circle))
- (new (make-circle-with values)))
- (circle-tie l (circle-next new))
- (circle-tie (circle-prev new) s)))
+ (unless (null values)
+ (circle-append-circle circle (make-circle-with values)))
(values))
--- a/src/wam/compiler.lisp Fri May 13 20:00:52 2016 +0000
+++ b/src/wam/compiler.lisp Sat May 14 18:52:14 2016 +0000
@@ -555,15 +555,15 @@
Actual queries are a special case where the `head-tokens` stream is `nil`
- The compiled instructions will be returned as a list.
+ The compiled instructions will be returned as a circle.
"
(let ((seen (list))
(mode nil)
- (instructions nil))
+ (instructions (make-empty-circle)))
(labels
((push-instruction (&rest instruction)
- (push instruction instructions))
+ (circle-insert-end instructions instruction))
(handle-argument (argument-register source-register)
;; OP X_n A_i
(let ((newp (push-if-new source-register seen :test #'register=)))
@@ -607,8 +607,7 @@
(handle-stream head-tokens))
(setf mode :query)
(handle-stream body-tokens)
- ;; TODO: this could suck less
- (reverse instructions))))
+ instructions)))
(defun find-variables (terms)
@@ -647,13 +646,15 @@
(defun precompile-clause (wam head body)
- "Compile the clause, returning a list of instructions the permanent variables.
+ "Precompile the clause.
`head` should be the head of the clause for program clauses, or `nil` for
query clauses.
`body` is the body of the clause, or `nil` for facts.
+ Returns a circle of instructions and the permanent variables.
+
"
(let* ((permanent-variables
(if (null head)
@@ -683,29 +684,28 @@
(loop :for term :in (rest body) :append
(tokenize-query-term term
permanent-variables))))))
- (flet ((compile% () (precompile-tokens wam head-tokens body-tokens)))
+ (let ((instructions (precompile-tokens wam head-tokens body-tokens))
+ (variable-count (length permanent-variables)))
;; We need to compile facts and rules differently. Facts end with
;; a PROCEED and rules are wrapped in ALOC/DEAL.
- (values
- (cond
- ((and head body) ; a full-ass rule
- `((:allocate ,(length permanent-variables))
- ,@(compile%)
- (:deallocate)))
- ((and head (null body)) ; a bare fact
- `(,@(compile%)
- (:proceed)))
- (t ; a query
- ;; The book doesn't have this ALOC here, but we do it to aid in result
- ;; extraction. Basically, to make extracting th results of a query
- ;; easier we allocate all of its variables on the stack, so we need
- ;; push a stack frame for them before we get started. We don't DEAL
- ;; because we want the frame to be left on the stack at the end so we
- ;; can poke at it.
- `((:allocate ,(length permanent-variables))
- ,@(compile%)
- (:done))))
- permanent-variables))))
+ (cond
+ ((and head body) ; a full-ass rule
+ (circle-insert-beginning instructions `(:allocate ,variable-count))
+ (circle-insert-end instructions `(:deallocate)))
+
+ ((and head (null body)) ; a bare fact
+ (circle-insert-end instructions `(:proceed)))
+
+ (t ; a query
+ ;; The book doesn't have this ALOC here, but we do it to aid in result
+ ;; extraction. Basically, to make extracting th results of a query
+ ;; easier we allocate all of its variables on the stack, so we need
+ ;; push a stack frame for them before we get started. We don't DEAL
+ ;; because we want the frame to be left on the stack at the end so we
+ ;; can poke at it.
+ (circle-insert-beginning instructions `(:allocate ,variable-count))
+ (circle-insert-end instructions `(:done))))
+ (values instructions permanent-variables))))
(defun precompile-query (wam query)
@@ -739,8 +739,8 @@
Each rule in `rules` should be a clause consisting of a head term and zero or
more body terms. A rule with no body is called a fact.
- Returns the list of compiled instructions, as well as the functor and arity of
- the rules being compiled.
+ Returns the circle of compiled instructions, as well as the functor and arity
+ of the rules being compiled.
"
(assert rules () "Cannot compile an empty program.")
@@ -754,14 +754,18 @@
;; choice point instruction first, then their actual code.
;;
;; The `nil` clause addresses will get filled in later, during rendering.
- (loop :for ((head . body) . remaining) :on rules
+ (loop :with instructions = (make-empty-circle)
+ :for ((head . body) . remaining) :on rules
:for first-p = t :then nil
:for last-p = (null remaining)
- :append
- (cons (cond (first-p '(:try nil))
- (last-p '(:trust))
- (t '(:retry nil)))
- (precompile-clause wam head body))))
+ :for clause-instructions = (precompile-clause wam head body)
+ :do
+ (circle-insert-end instructions
+ (cond (first-p '(:try nil))
+ (last-p '(:trust))
+ (t '(:retry nil))))
+ (circle-append-circle instructions clause-instructions)
+ :finally (return instructions)))
functor
arity)))
@@ -806,6 +810,7 @@
(number argument))) ; just a numeric argument, e.g. alloc 0
(defun render-bytecode (code instructions)
+ "Render `instructions` (a circle) into `code` (a bytecode array)."
(let ((previous-jump nil))
(flet
((fill-previous-jump (address)
@@ -813,7 +818,7 @@
(setf (aref code (1+ previous-jump)) address))
(setf previous-jump address)))
(loop
- :for (opcode . arguments) :in instructions
+ :for (opcode . arguments) :in (circle-to-list instructions)
:for address = (code-push-instruction! code
(render-opcode opcode)
(mapcar #'render-argument arguments))
--- a/test/run.lisp Fri May 13 20:00:52 2016 +0000
+++ b/test/run.lisp Sat May 14 18:52:14 2016 +0000
@@ -10,9 +10,9 @@
(when (not (5am:results-status result))
(setf *passed* nil))))
-; (test :bones)
-; (test :bones.paip)
-; (test :bones.wam)
+(test :bones)
+(test :bones.paip)
+(test :bones.wam)
(test :bones.circle)
(sb-ext:exit :code (if *passed* 0 1))