Add some compiler macros and other tweaks to build clean

shop3/decls.lisp

@@ -216,6 +216,13 @@ so we can avoid duplicate plans.")
                                              (t (quotify (cadr y)))))))
              (cons type args)))))
 
+(defmacro verify-type (place type)
+  "Like check-type, but without the continue option.
+
+This is nicer on SBCL."
+  `(or (typep ,place ',type)
+       (error 'type-error :datum ,place :expected-type ',type)))
+
 ;;;
 (declaim (inline primitivep))
 (defun primitivep (x)

shop3/explicit-stack-search/decls.lisp

@@ -1,4 +1,4 @@
-(in-package :shop2)
+(in-package :shop)
 
 (defclass search-state ()
   (

shop3/explicit-stack-search/explicit-search.lisp

@@ -187,7 +187,7 @@ objects."
 (declaim
  (ftype
   (function (search-state &key (:repairable t))
-            (values (or t nil) &optional list))
+            (values (member t nil) &optional list))
   test-plan-found))
 
 
@@ -412,7 +412,7 @@ is directed by DOMAIN and WHICH arguments.")
 of PLAN-RETURN objects."
   (if unpack-returns
    (iter (for pr in pr-list)
-     (check-type pr plan-return)
+     (verify-type pr plan-return)
      (with-slots (plan tree lookup-table replay-table world-state) pr
        (collecting plan into plans)
        (collecting tree into trees)
@@ -736,13 +736,13 @@ bound around calls."
 
 (declaim (ftype (function (search-state choice-entry) choice-entry) stack-backjump))
 (defun stack-backjump (state target)
-  (check-type target choice-entry)
+  (verify-type target choice-entry)
   (iter (for entry = (stack-backtrack state))
     (when (eq entry target)
       (return target))))
 
 (defun remove-subtree-from-table (hash-table subtree)
-  (check-type subtree plan-tree:tree-node)
+  (verify-type subtree plan-tree:tree-node)
   (labels ((remove-forest (forest)
                (if (null forest) nil
                    (or (remove-subtree (first forest))

shop3/pddl/pddl.lisp

@@ -855,17 +855,18 @@ set of dependencies."
                           (shopthpr:find-satisfiers (list fluent-goal) state
                                                     :level (1+ depth)
                                                     :just-one t :domain domain)
-                        (assert unifiers ()
-                                "Unable to find current value for ~s in fluent update"
-                                fluent-function)
+                        (unless unifiers
+                                (error "Unable to find current value for ~s in fluent update"
+                                 fluent-function))
                         (setf new-deps (first deps))
                         (apply-substitution '?value (first unifiers)))))
+        (verify-type old-val number)
         (let* ((update-val (cond ((fluent-expr-p domain new-value-expr)
                                   (multiple-value-bind (unifiers deps)
                                       (shopthpr:find-satisfiers `(f-exp-value ,new-value-expr ?val)
                                                                 state :domain domain
-                                                                      :level (1+ depth)
-                                                                      :just-one t)
+                                                                :level (1+ depth)
+                                                                :just-one t)
                                     (assert unifiers ()
                                             "Unable to find update value ~s in ~s"
                                             new-value-expr effect-expr)
@@ -881,12 +882,14 @@ set of dependencies."
                                  (t (error "Could not evaluate fluent update expression ~s in ~s"
                                            new-value-expr effect-expr))))
                ;; apply the op
-               (new-val (ecase op
+               (new-val
+                 (progn (verify-type update-val number)
+                        (ecase op
                           (assign update-val)
                           (scale-up (* old-val update-val))
                           (scale-down (* old-val update-val))
                           (increase (+ old-val update-val))
-                          (decrease (- old-val update-val)))))
+                          (decrease (- old-val update-val))))))
           (values
            ;; add the new value to the adds
            (list `(fluent-value ,fluent-function ,new-val))

shop3/theorem-prover/theorem-prover.lisp

@@ -90,6 +90,22 @@ non-NIL."
            (real-seek-satisfiers ,d ,goals ,state
                                  ,var-val-list ,level ,just1 ,dependencies)))))
 
+(define-compiler-macro seek-satisfiers (&whole form
+                                        goals state var-val-list level just1
+                                        &key (domain nil domain-supp-p)
+                                          dependencies
+                                          &environment env)
+  (declare (ignore form))
+  (cond ((and (constantp goals env) (null goals))
+         ;;(format t "~&Compiling away null goals in ~S~%" form)
+         `(values (list ,var-val-list) (list ,dependencies)))
+        ((not domain-supp-p)
+         ;;(format t "~&Supplying default domain argument in ~S~%" form)
+         `(real-seek-satisfiers *domain* ,goals ,state ,var-val-list ,level ,just1 ,dependencies))
+        (t ; domain *is* supplied
+         ;; (format t "~&Compiling away check for default domain argument in ~S~%" form)
+         `(real-seek-satisfiers ,domain ,goals ,state ,var-val-list ,level ,just1 ,dependencies))))
+
 (defgeneric query (goals state &key just-one domain return-dependencies record-dependencies)
   (:documentation
    "Find and return a list of binding lists that represents the answer to goals.
@@ -590,7 +606,7 @@ in the goal, so we ignore the extra reference."
     (cond
       ((variablep var)
        ;; FIXME: according to SBCL, the following is unreachable code,
-       ;; /specifically/ the calls to `apply-substitution, which is
+       ;; /specifically/ the invocation of `other-goals` and `bindings`, which is
        ;; disturbing [2022/11/23:rpg]
        (seek-satisfiers
         (apply-substitution other-goals (list (make-binding var ans)))

shop3/unification/unify.lisp

@@ -190,6 +190,15 @@ symbol with the corresponding value (if any) in SUBSTITUTION"
   `(if (null ,substitution) ,target
     (real-apply-substitution ,target ,substitution)))
 
+(define-compiler-macro apply-substitution (&whole form target substitution &environment env)
+  (cond ((and (constantp substitution env) (null substitution))
+         (format t "~&Compiling away null substitution in ~S~%" form)
+         target)
+        ((and (constantp target env) (null target))
+         (format t "~&Compiling away null target in ~S~%" form)
+         '(values nil))
+        (t form)))
+
 ;;; notes:  called by
 ;;;   COMPOSE-SUBSTITUTIONS, :OPERATOR
 ;;;   UNIFY, :OPERATOR