lib: error message cleanup.

Eliminate function names from message string literals;
they are interpolated via ~s from the symbol.
Consistently use compile-error in macros.

* share/txr/stdlib/asm.tl (asm-error): New function.
(oc-base backpatch, assembler (define-label, parse-args,
asm-one), bits-to-obj): Use asm-error.

* share/txr/stdlib/awk.tl (awk-error): New function.
(awk-state rec-to-f, awk-expander): Use awk-error.

* share/txr/stdlib/conv.tl (conv): Function name
out of string literal.

* share/txr/stdlib/getopts.tl (getopts-error): New function.
(opt-desc): Use getopts-error.

* share/txr/stdlib/ifa.tl (ifa): Use compile-error; use
symbol for name.
(if-to-cond): Use compile-error.

* share/txr/stdlib/place.tl (shift, defplace, get-mb): Use compile-error.
(lset, placelet*, placelet): Use compile-error; use symbol for name.

* share/txr/stdlib/socket.tl (str-inaddr, str-in6addr,
str-inaddr-net-impl, str-inaddr-net, str-in6addr-net): Use
symbols for function names.

* share/txr/stdlib/txr-case.tl (txr-case-impl): Use
compile-error and symbol for function name.

* share/txr/stdlib/with-resources.tl (with-resources): Use
compile-error and symbol for function name.

9 files changed, 66 insertions, 58 deletions

diff --git a/share/txr/stdlib/asm.tl b/share/txr/stdlib/asm.tl
index 08f378c0..25dd009f 100644
--- a/share/txr/stdlib/asm.tl
+++ b/share/txr/stdlib/asm.tl
@@ -41,7 +41,7 @@
                  n syntax)))
 
   (:method backpatch (me asm at offs)
-    (error `assembler: @{me.symbol} doesn't backpatch`)))
+    (asm-error `@{me.symbol} doesn't backpatch`)))
 
 (defmacro small-op-p (val)
   ^(< ,val ,1024))
@@ -100,7 +100,7 @@
 (defmeth assembler read-buf (me bytes)
   (let ((buf (make-buf bytes)))
     (when (neql (fill-buf buf 0 me.bstr) bytes)
-      (error "assembler: read past instruction block"))
+      (asm-error "read past instruction block"))
     buf))
 
 (defmeth assembler put-word (me word)
@@ -162,8 +162,7 @@
                               (parse-compound-operand arg))
                              ((symbolp arg)
                               (parse-operand (symbol-name arg)))))
-                          (t (error "assembler: invalid arg type spec ~s"
-                                    type)))))
+                          (t (asm-error "invalid arg type spec ~s" type)))))
               (unless (or parg (eq type 'o))
                 oc.(synerr "argument ~a of ~s invalid; ~a expected"
                            n syntax [me.operand-name type]))
@@ -187,17 +186,17 @@
               ((is-label syntax) [%oc-hash% 'label])
               ((consp syntax) [%oc-hash% (car syntax)]))))
     (unless oc
-      (error "assembler: invalid instruction ~s" syntax))
+      (asm-error "invalid instruction ~s" syntax))
     oc.(asm me syntax)))
 
 (defmeth assembler asm (me insns)
   (each ((i insns))
     me.(asm-one i))
   (unless (empty me.labref)
-    (error "assembler: dangling label references"))
+    (asm-error "dangling label references"))
   (whenlet ((n (cdr [find-max me.labdef : cdr])))
     (unless (< -1 n (len me.buf))
-      (error "assembler: labels outside of code"))))
+      (asm-error "labels outside of code"))))
 
 (defmeth assembler dis-one (me)
   (tree-bind (code extension operand) me.(get-insn)
@@ -236,6 +235,9 @@
 
 (defparml %oc-code% 0)
 
+(defun asm-error (msg . args)
+  (error `~s: @msg` 'assembler . args))
+
 (defun register-opcode (oc)
   %oc-list-builder%.(add oc)
   (set [%oc-hash% oc.symbol] oc)
@@ -286,7 +288,7 @@
     (caseq tag
       (1 (sign-extend val (- width 2)))
       (2 (chr-int val))
-      (t (error "assembler: bad immediate operand: ~s" bits)))))
+      (t (error "~s: bad immediate operand: ~s" 'assembler bits)))))
 
 (defmacro enc-small-op (val) val)
 
diff --git a/share/txr/stdlib/awk.tl b/share/txr/stdlib/awk.tl
index cb6e73c9..dee43dcd 100644
--- a/share/txr/stdlib/awk.tl
+++ b/share/txr/stdlib/awk.tl
@@ -91,7 +91,7 @@
              self.nf i)))
     (self.fs
       (when self.ft
-        (throwf 'eval-error "awk: both fs and ft set"))
+        (awk-error "both fs and ft set"))
       (if (and (not self.kfs) (equal self.rec ""))
         (set self.fields nil
              self.nf 0)
@@ -203,6 +203,9 @@
     ((memq kind '(:outf outp)) (flush-stream stream) val)
     (val)))
 
+(defun awk-error (msg . args)
+  (throwf 'eval-error `~s: @msg` 'awk . args))
+
 (defun sys:awk-test (val rec)
   (caseq (typeof val)
     ((regex fun) (call val rec))
@@ -297,30 +300,23 @@
         ((pattern . actions) (caseql pattern
                                (:inputs
                                  (when awc.inputs
-                                   (throwf 'eval-error
-                                           "awk: duplicate :input clauses"))
+                                   (awk-error "duplicate :input clauses"))
                                  (set awc.inputs actions))
                                (:output
                                  (when awc.output
-                                   (throwf 'eval-error
-                                           "awk: duplicate :input clauses"))
+                                   (awk-error "duplicate :output clauses"))
                                  (when (or (atom actions) (cdr actions))
-                                   (throwf 'eval-error
-                                           "awk: bad :output syntax"))
+                                   (awk-error "bad :output syntax"))
                                  (set awc.output (car actions)))
                                (:name
                                  (when awc.name
-                                   (throwf 'eval-error
-                                           "awk: duplicate :name clauses"))
+                                   (awk-error "duplicate :name clauses"))
                                  (when (or (atom actions) (cdr actions))
-                                   (throwf 'eval-error
-                                           "awk: bad :name syntax"))
+                                   (awk-error "bad :name syntax"))
                                  (unless (car actions)
-                                   (throwf 'eval-error
-                                           "awk: null :name not permitted"))
+                                   (awk-error "null :name not permitted"))
                                  (unless (symbolp (car actions))
-                                   (throwf 'eval-error
-                                           "awk: :name must be a symbol"))
+                                   (awk-error ":name must be a symbol"))
                                  (set awc.name (car actions)))
                                (:let (push actions awc.lets))
                                (:begin (push actions awc.begin-actions))
@@ -333,7 +329,7 @@
                                           cl
                                           ^(,pattern (prn)))
                                         awc.cond-actions))))
-        (junk (throwf 'eval-error "awk: bad clause syntax ~s" junk))))
+        (junk (awk-error "bad clause syntax ~s" junk))))
     (set awc.lets [apply append (nreverse awc.lets)]
          awc.begin-actions [apply append (nreverse awc.begin-actions)]
          awc.end-actions [apply append (nreverse awc.end-actions)]
diff --git a/share/txr/stdlib/conv.tl b/share/txr/stdlib/conv.tl
index 7c9a6608..bfcacde3 100644
--- a/share/txr/stdlib/conv.tl
+++ b/share/txr/stdlib/conv.tl
@@ -91,7 +91,7 @@
   (cond
     ((null specs) list-expr)
     ((atom specs)
-     (throwf 'eval-error "sys:conv: invalid conversion list: ~s" specs))
+     (throwf 'eval-error "~s: invalid conversion list: ~s" 'conv specs))
     (t (with-gensyms (list-sym)
          ^(let ((,list-sym ,list-expr))
             ,(sys:conv-expand form specs list-sym)
diff --git a/share/txr/stdlib/getopts.tl b/share/txr/stdlib/getopts.tl
index 91b85292..e6ac254a 100644
--- a/share/txr/stdlib/getopts.tl
+++ b/share/txr/stdlib/getopts.tl
@@ -59,6 +59,9 @@
 (defun sys:opt-err (. args)
   (throwf 'opt-error . args))
 
+(defun getopts-error (msg . args)
+  (error `~s: @msg` 'getopts . args))
+
 (defun sys:opt-dash (name)
   `@(if (> (length name) 1) "-")-@name`)
 
@@ -67,18 +70,18 @@
               (fboundp me.type)
               (and (consp me.type) (eq (car me.type) 'list))
               (member me.type me.valid-types))
-    (error "getopts: type must be a function or valid keyword, not ~s"
-           me.type))
+    (getopts-error "type must be a function or valid keyword, not ~s"
+                   me.type))
   (when me.long
     (when (< (length me.long) 2)
-      (error "getopts: long option ~a has a short name" me.long))
+      (getopts-error "long option ~a has a short name" me.long))
     (when (eql [me.long 0] #\-)
-      (error "getopts: long option ~a starts with - character" me.long)))
+      (getopts-error "long option ~a starts with - character" me.long)))
   (when me.short
     (when (neq (length me.short) 1)
-      (error "getopts: short option ~a not one character long" me.short))
+      (getopts-error "short option ~a not one character long" me.short))
     (when (eql [me.short 0] #\-)
-      (error "getopts: short option ~a starts with - character" me.short))))
+      (getopts-error "short option ~a starts with - character" me.short))))
 
 (defmeth sys:opt-parsed convert-type (me)
   (let ((name (sys:opt-dash me.name))
diff --git a/share/txr/stdlib/ifa.tl b/share/txr/stdlib/ifa.tl
index 8639956b..3684b10f 100644
--- a/share/txr/stdlib/ifa.tl
+++ b/share/txr/stdlib/ifa.tl
@@ -32,8 +32,8 @@
                                              (if it ,then ,else)))
       ((member (first test) '(not null false))
        (unless (eql (length test) 2)
-         (throwf 'eval-error "ifa: wrong number of arguments to ~s"
-                 (first test)))
+         (compile-error "~s: wrong number of arguments to ~s"
+                        'ifa (first test)))
        ^(ifa ,(second test) ,else ,then))
       (t (let* ((sym (first test))
                 (args (if (eq 'dwim sym) (cddr test) (cdr test)))
@@ -43,11 +43,11 @@
                        (and (or (functionp (symbol-function sym))
                                 (eq sym 'dwim)
                                 (null (symbol-function sym)))))
-             (throwf 'eval-error "ifa: test expression must be \
-                                 \ a simple function call"))
+             (compile-error "~s: test expression must be \
+                            \ a simple function call" 'ifa))
            (when (> n-candidate-args 1)
-             (throwf 'eval-error "ifa: ambiguous situation: \
-                                 \ not clear what can be \"it\""))
+             (compile-error "~s: ambiguous situation: \
+                            \ not clear what can be \"it\"" 'ifa))
            (iflet ((it-form (macroexpand [args pos-candidate] e))
                    (is-place (place-form-p it-form e)))
              (let ((before-it [args 0..pos-candidate])
@@ -74,7 +74,7 @@
     (((test . forms) . rest) ^(,if-oper ,test (progn ,*forms)
                                         (,cond-oper ,*rest)))
     (() ())
-    (else (throwf 'eval-error "~s: bad syntax: ~s" cond-oper pairs))))
+    (else (compile-error "~s: bad syntax: ~s" cond-oper pairs))))
 
 (defmacro conda (. pairs)
   (sys:if-to-cond 'ifa 'conda pairs))
diff --git a/share/txr/stdlib/place.tl b/share/txr/stdlib/place.tl
index 6b4a1019..26ca1d94 100644
--- a/share/txr/stdlib/place.tl
+++ b/share/txr/stdlib/place.tl
@@ -292,8 +292,8 @@
 
 (defmacro shift (:env env . places)
   (tree-case places
-    (() (sys:eval-err "shift: need at least two arguments"))
-    ((place) (sys:eval-err "shift: need at least two arguments"))
+    (() (compile-error "~s: need at least two arguments" 'shift))
+    ((place) (compile-error "~s: need at least two arguments" 'shift))
     ((place newvalue)
      (with-update-expander (getter setter) place env
         ^(prog1 (,getter) (,setter ,newvalue))))
@@ -345,7 +345,8 @@
         (orig (gensym))
         (iter (gensym)))
     (unless places
-      (sys:eval-err "lset: require one or more places followed by expression"))
+      (compile-error "~s: require one or more places followed by expression"
+                     'lset))
     ^(let* ((,orig ,(car source))
             (,iter ,orig))
        ,*(butlast (mappend (ret ^((set ,@1 (car ,iter)) (set ,iter (cdr ,iter))))
@@ -367,8 +368,8 @@
                  (symbolp name)
                  (not (keywordp name))
                  (not (eq t name)))
-      (sys:eval-err "~s: ~s cannot be used as a place name"
-                'defplace name))
+      (compile-error "~s: ~s cannot be used as a place name"
+                     'defplace name))
     (with-gensyms (place)
       ^(progn
          (sethash *place-update-expander* ',name
@@ -767,9 +768,9 @@
   (deleter
     ^(macrolet ((,deleter (:env env)
                    (when (lexical-fun-p env ',sym)
-                     (sys:eval-err "~s is a lexical function, \
-                                   \ thus not deletable"
-                                 ',sym))
+                     (compile-error "~s is a lexical function, \
+                                    \ thus not deletable"
+                                    ',sym))
                     ^(fmakunbound ',',sym)))
        ,body)))
 
@@ -812,7 +813,7 @@
 
 (defun sys:get-mb (sym)
   (or (gethash sys:top-mb sym)
-      (sys:eval-err "unbound macro ~s" sym)))
+      (compile-error "unbound macro ~s" sym)))
 
 (defplace (symbol-macro sym-expr) body
   (getter setter
@@ -883,12 +884,12 @@
     (((sym place)) ^(sys:placelet-1 ((,sym ,place)) ,*body))
     (((sym place) . rest-pairs) ^(sys:placelet-1 ((,sym ,place))
                                    (placelet* (,*rest-pairs) ,*body)))
-    (obj (throwf 'eval-error "placelet*: bad syntax: ~s" obj))))
+    (obj (compile-error "~s: bad syntax: ~s" 'placelet* obj))))
 
 (defmacro placelet (sym-place-pairs . body)
   (unless (all sym-place-pairs
                [andf consp (opip length (= 2)) (oand first bindable)])
-    (throwf 'eval-error "placelet: bad syntax: ~s" sym-place-pairs))
+    (compile-error "~s: bad syntax: ~s" 'placelet 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/socket.tl b/share/txr/stdlib/socket.tl
index d93e0c0e..a76197eb 100644
--- a/share/txr/stdlib/socket.tl
+++ b/share/txr/stdlib/socket.tl
@@ -57,7 +57,8 @@
         (a         (ash addr -24))
         (p (if port `:@port` "")))
     (if (or (> a 255) (minusp a))
-      (throwf 'eval-error "str-inaddr: ~a out of range for IPv4 address" addr)
+      (throwf 'eval-error "~s: ~a out of range for IPv4 address"
+              'str-inaddr addr)
       `@a.@b.@c.@d@p`)))
 
 (defun sys:in6addr-condensed-text (numeric-pieces)
@@ -82,9 +83,10 @@
                                                 (if (minusp (dec count))
                                                   (unless (zerop val)
                                                     (throwf 'eval-error
-                                                            "str-in6addr: \
+                                                            "~s: \
                                                             \ ~a out of range \
                                                             \ for IPv6 address"
+                                                            'str-in6addr
                                                             addr))
                                                   (cons (logand val #xFFFF)
                                                         (ash val -16))))
@@ -109,8 +111,8 @@
            (we (or weff (+ w wextra))))
       (cond
         ((or (> a 255) (minusp a))
-         (throwf 'eval-error "str-inaddr-net: ~a out of range for IPv4 address"
-                 addr))
+         (throwf 'eval-error "~s: ~a out of range for IPv4 address"
+                 'str-inaddr-net addr))
         ((> w 24) `@a.@b.@c.@d/@we`)
         ((> w 16) `@a.@b.@c/@we`)
         ((> w 8) `@a.@b/@we`)
@@ -137,9 +139,10 @@
                                        (if (minusp (dec count))
                                          (unless (zerop val)
                                            (throwf 'eval-error
-                                                   "str-in6addr-net: \
+                                                   "~s: \
                                                    \ ~a out of range \
                                                    \ for IPv6 address"
+                                                   'str-in6addr-net
                                                    addr))
                                            (cons (logand val #xFFFF)
                                                  (ash val -16))))
diff --git a/share/txr/stdlib/txr-case.tl b/share/txr/stdlib/txr-case.tl
index 5a320127..80d32161 100644
--- a/share/txr/stdlib/txr-case.tl
+++ b/share/txr/stdlib/txr-case.tl
@@ -55,12 +55,15 @@
     (((sym . rest) . other-clauses)
      (if (eq sym t)
        (if other-clauses
-         (error "txr-case: clauses after (t ...) clause ignored")
+         (compile-error "~s: clauses after (t ...) clause ignored"
+                        'txr-case)
          ^(progn ,*rest))
-       (error "txr-case: bad syntax: ~s" (car clauses))))
+       (compile-error "~s: bad syntax: ~s" (car clauses)
+                      'txr-case)))
     (() ())
     (atom
-       (error "txr-case: unexpected atom in syntax: ~s" atom))))
+       (compile-error "~s: unexpected atom in syntax: ~s"
+                      'txr-case 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 273fbd9d..310f4b5c 100644
--- a/share/txr/stdlib/with-resources.tl
+++ b/share/txr/stdlib/with-resources.tl
@@ -40,7 +40,7 @@
         (with-resources ,rest ,*body)))
     (nil
       ^(progn ,*body))
-    (other (error "with-resources: bad syntax"))))
+    (other (compile-error "~s: bad syntax" 'with-resources))))
 
 (defmacro with-objects (var-init-forms . body)
   (let ((gens (mapcar (ret (gensym)) var-init-forms)))