Changeset 14365

Timestamp:

Oct 14, 2010, 8:15:03 PM (14 years ago)

Author:

Gary Byers

Message:

Admit that the macro CCL::REPORT-BAD-ARG has accepted exactly 2 arguments
for the last 20+ years. If the second argument (the typespec) is quoted,
warn at macroexpand time if it looks suspicious.

Fix a handful of cases that were detected by that change. In one
case, introduce a predicate so that EXPT can complain about an
argument whose realpart isn't positive via a SATISFIES type specifier.

Location:

trunk/source

Files:

• level-0/l0-float.lisp (modified) (2 diffs)
• level-1/l1-clos-boot.lisp (modified) (1 diff)
• level-1/l1-streams.lisp (modified) (2 diffs)
• lib/macros.lisp (modified) (1 diff)

trunk/source/level-0/l0-float.lisp

@@ -819 +819 @@
 
 
+(defun positive-realpart-p (n)
+  (> (realpart n) 0))
 
 (defun expt (b e)
@@ -826 +828 @@
          (if (minusp e) (/ 1 (%integer-power b (- e))) (%integer-power b e)))
         ((zerop b)
-         (if (plusp (realpart e)) b (report-bad-arg e '(number (0) *))))
+         (if (plusp (realpart e)) b (report-bad-arg e '(satisfies positive-realpart-p))))
         ((and (realp b) (plusp b) (realp e))
          (if (or (typep b 'double-float)

trunk/source/level-1/l1-clos-boot.lisp

@@ -3199 +3199 @@
            (setq old-wrapper (gf.instance.class-wrapper instance)))
          (unless old-wrapper
-           (report-bad-arg instance '(or standard-instance funcallable-standard-object))))
+           (report-bad-arg instance '(or standard-object funcallable-standard-object))))
        (when (eql 0 (%wrapper-instance-slots old-wrapper)) ; is it really obsolete?
          (let* ((class (%wrapper-class old-wrapper))

trunk/source/level-1/l1-streams.lisp

@@ -6430 +6430 @@
               (setf (fill-pointer displaced) newpos)))
           newpos)
-        (report-bad-arg newpos `(integer 0 `(,(- (the fixnum (io-buffer-limit outbuf)) origin)))))
+        (report-bad-arg newpos `(integer 0 (,(- (the fixnum (io-buffer-limit outbuf)) origin)))))
       (the fixnum (- (the fixnum (io-buffer-idx outbuf)) origin)))))
 
@@ -6585 +6585 @@
           (setf (io-buffer-idx inbuf) (the fixnum (+ origin (the fixnum newpos))))
           newpos)
-        (report-bad-arg newpos `(integer 0 `(,(- (the fixnum (io-buffer-limit inbuf)) origin)))))
+        (report-bad-arg newpos `(integer 0 (,(- (the fixnum (io-buffer-limit inbuf)) origin)))))
       (the fixnum (- (the fixnum (io-buffer-idx inbuf)) origin)))))
 

trunk/source/lib/macros.lisp

@@ -264 +264 @@
           ,@(if ret `((progn (setq ,varsym nil) ,ret))))))))
 
-(defmacro report-bad-arg (&rest args)
-  `(values (%badarg ,@args)))
+(defmacro report-bad-arg (&whole w thing typespec &environment env)
+  (when (quoted-form-p typespec)
+    (unless (ignore-errors (specifier-type-if-known (cadr typespec) env))
+      (warn "Unknown type specifier ~s in ~s." (cadr typespec) w)))
+  `(values (%badarg ,thing ,typespec)))
 
 (defmacro %cons-restart (name action report interactive test)