Changeset 278

Timestamp:

Jan 13, 2004, 4:55:02 PM (21 years ago)

Author:

Gary Byers

Message:

Fix ASSOC and friends, broken just a few days ago. Signal PROGRAM-ERROR
when detecting argument mismatches in macros.

File:

• trunk/ccl/level-1/l1-utils.lisp (modified) (8 diffs)

trunk/ccl/level-1/l1-utils.lisp

@@ -279 +279 @@
 (setf (type-predicate 'macptr) 'macptrp)
 
-(defun null-or-handlep (arg)
-  (and (macptrp arg)
-       (or (%null-ptr-p arg)
-           (handlep arg))))
-
-(defun require-null-or-handlep (arg)
-  (if (null-or-handlep arg)
-    arg
-    (require-type arg '(satisfies null-or-handlep))))
+
 
 
@@ -309 +301 @@
 (defun %check-extra-arguments (ptr)
   (when (destructure-state.current ptr)
-    (error "Extra arguments in ~s don't match lambda list ~s."
-               (destructure-state.whole ptr) (destructure-state.lambda ptr))))
+    (signal-program-error "Extra arguments in ~s don't match lambda list ~s."
+                          (destructure-state.whole ptr) (destructure-state.lambda ptr))))
 
 (defun %keyword-present-p (keys keyword)
@@ -324 +316 @@
         (signal-simple-program-error "Odd length keyword list: ~s" actual))))
   (setq allow-others (or allow-others (getf actual :allow-other-keys)))
-  (unless allow-others
-    (do* ((a actual (cddr a))
-          (k (car a) (car a)))
-         ((null a))
-      (unless (or (eq k :allow-other-keys)
-                  (member k keys))
-        (signal-simple-program-error "Unknown keyword argument ~s in ~s.  ~&Valid keyword arguments are ~s." k actual keys)))))
+  (do* ((a actual (cddr a))
+        (k (car a) (car a)))
+       ((null a))
+    (unless (typep k 'symbol)
+      (signal-simple-program-error
+       "Invalid keyword argument ~s in ~s.  ~&Valid keyword arguments are ~s." k actual keys))
+    (unless (or allow-others
+                (eq k :allow-other-keys)
+                (member k keys))
+      (signal-simple-program-error "Unknown keyword argument ~s in ~s.  ~&Valid keyword arguments are ~s." k actual keys))))
 
 (%fhave 'set-macro-function #'%macro-have)   ; redefined in sysutils.
@@ -450 +445 @@
       (if pair
         (if (eql item (car pair))
-          (return pair))
-        (report-bad-arg pair 'cons)))
+          (return pair))))
     (assq item list)))
 
@@ -462 +456 @@
     (if pair
       (if (funcall test-fn item (car pair))
-        (return pair))
-      (report-bad-arg pair 'cons))))
+        (return pair)))))
 
 
@@ -475 +468 @@
     (if pair
       (if (not (funcall test-not-fn item (car pair)))
-        (return pair))
-      (report-bad-arg pair 'cons))))
+        (return pair)))))
 
 (defun assoc (item list &key test test-not key)
@@ -492 +484 @@
           (if pair
             (if (funcall test item (funcall key (car pair)))
-              (return pair))
-            (report-bad-arg pair 'cons)))
+              (return pair))))
         (dolist (pair list)
           (if pair
             (unless (funcall test-not item (funcall key (car pair)))
-              (return pair))
-            (report-bad-arg pair 'cons)))))))
+              (return pair))))))))
 
 
@@ -851 +841 @@
 (defun eval-constant (form)
   (if (quoted-form-p form) (%cadr form)
-      (if (constant-symbol-p form) (symbol-value form)
-          (if (self-evaluating-p form) form
-              (report-bad-arg form '(satsifies constantp))))))
+    (if (constant-symbol-p form) (symbol-value form)
+      (if (self-evaluating-p form) form
+        (report-bad-arg form '(satisfies constantp))))))
 
 ; SETQ'd above before we could DEFVAR.