stdlib: fix incorrect uses of compile-error.

Oops! We have many instances of compile-error being called
in the old way with a format string as its first agument,
instead of a context argument.

* share/txr/stdlib/ifa.tl (ifa): Take :form argument, pass to
compile-error. Let's call this "fix M".
(sys:if-to-cond): Add form parameter, pass to compile-error.
Let's call this let's call this "fix F".
(conda, condlet): Fix M.

* share/txr/stdlib/place.tl (sys:*pl-form*): New special
variable. We need this in order to communicate the real place
form to the place expander, similarly to how we communicate
the original environment using sys:*pl-env*.
(call-update-expander, call-clobber-expander,
call-delete-expander): Bind sys:*pl-form* to the unexpanded
place.
(shift, lset): Fix M.
(defplace fun): Arrange for value of sys:*pl-form* to be
passed to compile-error. Let's call this "Fix P".
(sys:get-mb): Fix F.
(defplace symbol-macro): Fix P.
(placelet*, placelet): Fix M.

* share/txr/stdlib/txr-case.tl (txr-case-impl): Fix M.

* share/txr/stdlib/with-resources.tl (with-resources): Fix M.

4 files changed, 38 insertions, 40 deletions

diff --git a/share/txr/stdlib/ifa.tl b/share/txr/stdlib/ifa.tl
index a4dd4738..239de517 100644
--- a/share/txr/stdlib/ifa.tl
+++ b/share/txr/stdlib/ifa.tl
@@ -24,7 +24,7 @@
 ;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
 ;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 
-(defmacro ifa (:env e test then : else)
+(defmacro ifa (:env e :form f test then : else)
   (flet ((candidate-p (form)
            (not (or (constantp form e) (symbolp form)))))
     (cond
@@ -32,8 +32,7 @@
                                              (if it ,then ,else)))
       ((member (first test) '(not null false))
        (unless (eql (length test) 2)
-         (compile-error "~s: wrong number of arguments to ~s"
-                        'ifa (first test)))
+         (compile-error f "wrong number of arguments to ~s" (first test)))
        ^(ifa ,(second test) ,else ,then))
       (t (let* ((sym (first test))
                 (args (if (eq 'dwim sym) (cddr test) (cdr test)))
@@ -43,11 +42,11 @@
                        (and (or (functionp (symbol-function sym))
                                 (eq sym 'dwim)
                                 (null (symbol-function sym)))))
-             (compile-error "~s: test expression must be \
-                            \ a simple function call" 'ifa))
+             (compile-error f "test expression must be \
+                              \ a simple function call"))
            (when (> n-candidate-args 1)
-             (compile-error "~s: ambiguous situation: \
-                            \ not clear what can be \"it\"" 'ifa))
+             (compile-error f "ambiguous situation: \
+                              \ not clear what can be \"it\""))
            (iflet ((it-form (macroexpand [args pos-candidate] e))
                    (is-place (place-form-p it-form e)))
              (let ((before-it [args 0..pos-candidate])
@@ -69,15 +68,15 @@
 (defmacro whena (test . body)
   ^(ifa ,test (progn ,*body)))
 
-(defun sys:if-to-cond (if-oper cond-oper pairs)
+(defun sys:if-to-cond (f if-oper cond-oper pairs)
   (tree-case pairs
     (((test . forms) . rest) ^(,if-oper ,test (progn ,*forms)
                                         (,cond-oper ,*rest)))
     (() ())
-    (else (compile-error "~s: bad syntax: ~s" cond-oper pairs))))
+    (else (compile-error f "bad syntax: ~s" pairs))))
 
-(defmacro conda (. pairs)
-  (sys:if-to-cond 'ifa 'conda pairs))
+(defmacro conda (:form f . pairs)
+  (sys:if-to-cond f 'ifa 'conda pairs))
 
-(defmacro condlet (. pairs)
-  (sys:if-to-cond 'iflet 'condlet pairs))
+(defmacro condlet (:form f . pairs)
+  (sys:if-to-cond f 'iflet 'condlet pairs))
diff --git a/share/txr/stdlib/place.tl b/share/txr/stdlib/place.tl
index 20405396..0aef499a 100644
--- a/share/txr/stdlib/place.tl
+++ b/share/txr/stdlib/place.tl
@@ -29,6 +29,7 @@
 (defvar *place-delete-expander* (hash))
 (defvar *place-macro* (hash))
 (defvar sys:*pl-env* nil)
+(defvar sys:*pl-form* nil)
 
 (defun sys:eval-err (. params)
   (throwf 'eval-error . params))
@@ -147,6 +148,7 @@
   (let* ((place (sys:pl-expand unex-place env))
          (expander (get-update-expander place))
          (sys:*pl-env* env)
+         (sys:*pl-form* unex-place)
          (expansion [expander getter setter place body])
          (expansion-ex (expand expansion env)))
     (sys:propagate-ancestor expansion-ex place getter setter)))
@@ -156,6 +158,7 @@
   (let* ((place (sys:pl-expand unex-place env))
          (expander (get-clobber-expander place))
          (sys:*pl-env* env)
+         (sys:*pl-form* unex-place)
          (expansion [expander ssetter place body])
          (expansion-ex (expand expansion env)))
     (sys:propagate-ancestor expansion-ex place ssetter)))
@@ -165,6 +168,7 @@
   (let* ((place (sys:pl-expand unex-place env))
          (expander (get-delete-expander place))
          (sys:*pl-env* env)
+         (sys:*pl-form* unex-place)
          (expansion [expander deleter place body])
          (expansion-ex (expand expansion env)))
     (sys:propagate-ancestor expansion-ex place deleter)))
@@ -290,10 +294,10 @@
                  ,old-list-sym
                  (,setter (cons ,new-item-sym ,old-list-sym)))))))))
 
-(defmacro shift (:env env . places)
+(defmacro shift (:form f :env env . places)
   (tree-case places
-    (() (compile-error "~s: need at least two arguments" 'shift))
-    ((place) (compile-error "~s: need at least two arguments" 'shift))
+    (() (compile-error f "need at least two arguments"))
+    ((place) (compile-error f "need at least two arguments"))
     ((place newvalue)
      (with-update-expander (getter setter) place env
         ^(prog1 (,getter) (,setter ,newvalue))))
@@ -339,14 +343,13 @@
   (with-delete-expander (deleter) place env
     ^(,deleter)))
 
-(defmacro lset (. places-source)
+(defmacro lset (:form f . places-source)
   (let ((places (butlast places-source))
         (source (last places-source))
         (orig (gensym))
         (iter (gensym)))
     (unless places
-      (compile-error "~s: require one or more places followed by expression"
-                     'lset))
+      (compile-error f "require one or more places followed by expression"))
     ^(let* ((,orig ,(car source))
             (,iter ,orig))
        ,*(butlast (mappend (ret ^((set ,@1 (car ,iter)) (set ,iter (cdr ,iter))))
@@ -368,8 +371,7 @@
                  (symbolp name)
                  (not (keywordp name))
                  (not (eq t name)))
-      (compile-error "~s: ~s cannot be used as a place name"
-                     'defplace name))
+      (compile-error sys:*pl-form* "~s cannot be used as a place name" name))
     (with-gensyms (place)
       ^(progn
          (sethash *place-update-expander* ',name
@@ -768,9 +770,9 @@
   (deleter
     ^(macrolet ((,deleter (:env env)
                    (when (lexical-fun-p env ',sym)
-                     (compile-error "~s is a lexical function, \
-                                    \ thus not deletable"
-                                    ',sym))
+                     (compile-error ',sys:*pl-form*
+                                    "~s is a lexical function, \
+                                    \ thus not deletable"))
                     ^(fmakunbound ',',sym)))
        ,body)))
 
@@ -811,14 +813,14 @@
     ^(macrolet ((,deleter () ^(fmakunbound ,',sym-expr)))
        ,body)))
 
-(defun sys:get-mb (sym)
+(defun sys:get-mb (f sym)
   (or (gethash sys:top-mb sym)
-      (compile-error "unbound macro ~s" sym)))
+      (compile-error f "unbound macro ~s" sym)))
 
 (defplace (symbol-macro sym-expr) body
   (getter setter
     (with-gensyms (binding-sym)
-      ^(let ((,binding-sym (sys:get-mb ,sym-expr)))
+      ^(let ((,binding-sym (sys:get-mb ',sys:*pl-form* ,sym-expr)))
           (macrolet ((,getter () ^(cdr ,',binding-sym))
                      (,setter (val) ^(sys:rplacd ,',binding-sym ,val)))
             ,body))))
@@ -890,18 +892,18 @@
                          ,*body) env))))
       (remhash *place-update-expander* tmp-place))))
 
-(defmacro placelet* (sym-place-pairs . body)
+(defmacro placelet* (:form f sym-place-pairs . body)
   (tree-case sym-place-pairs
     (() ^(progn ,*body))
     (((sym place)) ^(sys:placelet-1 ((,sym ,place)) ,*body))
     (((sym place) . rest-pairs) ^(sys:placelet-1 ((,sym ,place))
                                    (placelet* (,*rest-pairs) ,*body)))
-    (obj (compile-error "~s: bad syntax: ~s" 'placelet* obj))))
+    (obj (compile-error f "bad syntax: ~s" obj))))
 
-(defmacro placelet (sym-place-pairs . body)
+(defmacro placelet (:form f sym-place-pairs . body)
   (unless (all sym-place-pairs
                [andf consp (opip length (= 2)) (oand first bindable)])
-    (compile-error "~s: bad syntax: ~s" 'placelet sym-place-pairs))
+    (compile-error f "bad syntax: ~s" sym-place-pairs))
   (tree-bind (: syms places) (transpose sym-place-pairs)
      (let ((temps (mapcar (ret (gensym)) syms)))
        ^(placelet* (,*(zip temps places))
diff --git a/share/txr/stdlib/txr-case.tl b/share/txr/stdlib/txr-case.tl
index bef5b358..57e44643 100644
--- a/share/txr/stdlib/txr-case.tl
+++ b/share/txr/stdlib/txr-case.tl
@@ -45,7 +45,7 @@
 (defmacro txr-when (name args input . body)
   ^(txr-if ,name ,args ,input (progn ,*body)))
 
-(defmacro txr-case-impl (sym . clauses)
+(defmacro txr-case-impl (:form f sym . clauses)
   (tree-case clauses
     (((name args . body) . other-clauses)
      (if (eq name t) :
@@ -55,15 +55,12 @@
     (((sym . rest) . other-clauses)
      (if (eq sym t)
        (if other-clauses
-         (compile-error "~s: clauses after (t ...) clause ignored"
-                        'txr-case)
+         (compile-error f "clauses after (t ...) clause ignored")
          ^(progn ,*rest))
-       (compile-error "~s: bad syntax: ~s" (car clauses)
-                      'txr-case)))
+       (compile-error f "bad syntax: ~s" (car clauses))))
     (() ())
     (atom
-       (compile-error "~s: unexpected atom in syntax: ~s"
-                      'txr-case atom))))
+       (compile-error f "unexpected atom in syntax: ~s" atom))))
 
 (defmacro txr-case (input-expr . clauses)
   (let ((input (gensym "input-")))
diff --git a/share/txr/stdlib/with-resources.tl b/share/txr/stdlib/with-resources.tl
index febf878b..0494982a 100644
--- a/share/txr/stdlib/with-resources.tl
+++ b/share/txr/stdlib/with-resources.tl
@@ -24,7 +24,7 @@
 ;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
 ;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 
-(defmacro with-resources (res-bindings . body)
+(defmacro with-resources (:form f res-bindings . body)
   (tree-case res-bindings
     (((sym init cleanup) . rest)
      ^(let ((,sym ,init))
@@ -40,7 +40,7 @@
         (with-resources ,rest ,*body)))
     (nil
       ^(progn ,*body))
-    (other (compile-error "~s: bad syntax" 'with-resources))))
+    (other (compile-error f "bad syntax"))))
 
 (defmacro with-objects (var-init-forms . body)
   (let ((gens (mapcar (ret (gensym)) var-init-forms)))