# HG changeset patch
# User Steve Losh <steve@stevelosh.com>
# Date 1460760123 0
# Node ID f0f0c180ae1dacbc7e8f39f18e0e0a3713fa8e78
# Parent  1dd07907df493ada2145a1715dfe219e2a6810fe
Add a REAL janky result extractor

This'll have to get overhauled once we support multi-goal queries, but for now
it'll do the job.

diff -r 1dd07907df49 -r f0f0c180ae1d src/wam/dump.lisp
--- a/src/wam/dump.lisp	Fri Apr 15 20:28:35 2016 +0000
+++ b/src/wam/dump.lisp	Fri Apr 15 22:42:03 2016 +0000
@@ -183,13 +183,14 @@
 
 
 (defun extract-thing (wam address)
-  "Extract the thing at the given heap address and print it nicely."
+  "Extract the thing at the given heap address."
   (let ((cell (wam-heap-cell wam (deref wam address))))
     (cond
       ((cell-null-p cell)
        "NULL!")
       ((cell-reference-p cell)
-       (format nil "var-~D" (cell-value cell)))
+       ;; TODO: figure out what the hell to return here
+       (gensym (format nil "var@~4,'0X-" (cell-value cell))))
       ((cell-structure-p cell)
        (extract-thing wam (cell-value cell)))
       ((cell-functor-p cell)
diff -r 1dd07907df49 -r f0f0c180ae1d src/wam/instructions.lisp
--- a/src/wam/instructions.lisp	Fri Apr 15 20:28:35 2016 +0000
+++ b/src/wam/instructions.lisp	Fri Apr 15 22:42:03 2016 +0000
@@ -1,4 +1,9 @@
 (in-package #:bones.wam)
+(named-readtables:in-readtable :fare-quasiquote)
+
+;;;; Config
+(defparameter *break-on-fail* nil)
+
 
 ;;;; Utilities
 (defun* push-unbound-reference! ((wam wam))
@@ -91,10 +96,14 @@
 
 (defun* fail! ((wam wam) (reason string))
   (:returns :void)
-  "Mark a failure in the WAM."
+  "Mark a failure in the WAM.
+
+  If `*break-on-fail*` is true, the debugger will be invoked.
+
+  "
   (setf (wam-fail wam) t)
-  (format *debug-io* "FAIL: ~A~%" reason)
-  (break)
+  (when *break-on-fail*
+    (break "FAIL: ~A~%" reason))
   (values))
 
 
@@ -302,6 +311,27 @@
             :collect `(aref ,code-store (+ ,pc ,i)))))
 
 
+(defun extract-query-results (wam goal)
+  (let ((results (list)))
+    (labels ((recur (original result)
+               (cond
+                 ((and (variable-p original)
+                       (not (assoc original results)))
+                  (push (cons original
+                              (match result
+                                (`(,bare-functor) bare-functor)
+                                (r r)))
+                        results))
+                 ((consp original)
+                  (recur (car original) (car result))
+                  (recur (cdr original) (cdr result)))
+                 (t nil))))
+      (loop :for argument :in (cdr goal)
+            :for a :from 0
+            :do (recur argument (extract-thing wam (wam-register wam a)))))
+    results))
+
+
 (defun run-program (wam functor &optional (step nil))
   (with-slots (code program-counter fail) wam
     (setf program-counter (wam-code-label wam functor))
@@ -328,9 +358,7 @@
         (incf program-counter (instruction-size opcode))
         (when (>= program-counter (fill-pointer code))
           (error "Fell off the end of the program code store!"))))
-    (if fail
-      (print "FAIL")
-      (print "SUCCESS"))))
+    (values)))
 
 (defun run-query (wam term &optional (step nil))
   "Compile query `term` and run the instructions on the `wam`.
@@ -361,6 +389,10 @@
         (incf pc (instruction-size opcode))
         (when (>= pc (length code)) ; queries SHOULD always end in a CALL...
           (error "Fell off the end of the query code store!")))))
+  (if (wam-fail wam)
+    (princ "No.")
+    (loop :for (var . val) :in (extract-query-results wam (first term))
+          :do (format t "~S -> ~S~%" var val)))
   (values))
 
 
diff -r 1dd07907df49 -r f0f0c180ae1d src/wam/wam.lisp
--- a/src/wam/wam.lisp	Fri Apr 15 20:28:35 2016 +0000
+++ b/src/wam/wam.lisp	Fri Apr 15 22:42:03 2016 +0000
@@ -225,9 +225,10 @@
   (wam-truncate-heap! wam)
   (wam-truncate-stack! wam)
   (wam-reset-registers! wam)
-  (setf (wam-program-counter wam) 0)
-  (setf (wam-continuation-pointer wam) 0)
-  (setf (wam-mode wam) nil))
+  (setf (wam-program-counter wam) 0
+        (wam-continuation-pointer wam) 0
+        (wam-fail wam) nil
+        (wam-mode wam) nil))
 
 
 ;;;; Code