Changeset 331

Timestamp:

Jan 19, 2004, 4:29:22 PM (21 years ago)

Author:

Gary Byers

Message:

GF's need to check keywords after all. Recognize :ALLOW-OTHER-KEYS T sooner,
don't treat :ALLOW-OTHER-KEYS NIL as an unknown argument.

File:

• trunk/ccl/level-1/l1-dcode.lisp (modified) (3 diffs)

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

@@ -953 +953 @@
 
 ; vector arg is (vector key-index keyvect combined-method) ; the next combined method
-#|
+
 (defun %%check-keywords (vector-arg args)
   (flet ((do-it (vector-arg args)
@@ -960 +960 @@
                   (keyvect-len (length keyvect))
                   (key-index (%svref vector-arg 0)))
-             ; vector arg is (vector key-index keyvect combined-method) ; the next combined method
+                                        ; vector arg is (vector key-index keyvect combined-method) ; the next combined method
              (declare (fixnum args-len key-index keyvect-len))
              (when (>= args-len key-index)
-               (let* ((keys-in (- args-len key-index))
-                      aok)  ; actually * 2
+               (let* ((keys-in (- args-len key-index))) ; actually * 2
                  (declare (fixnum  key-index keys-in keyvect-len))
                  (when (logbitp 0 keys-in) (odd-keys-error vector-arg (collect-lexpr-args args key-index args-len)))
-                 (setq aok (%cadr (pl-search args :allow-other-keys)))
-                 (do ((i key-index (+ i 2))
-                      (kargs (nthcdr key-index args) (cddr kargs)))
-                     ((eq i args-len))
-                   (declare (fixnum i))
-                   (when aok (return))
-                   (let ((key (car kargs)))
-                     (when (and (eq key :allow-other-keys)
-                                (cadr kargs))
-                       (return))
-                     (when (not (dotimes (i keyvect-len nil)
-                                  (if (eq key (%svref keyvect i))
-                                    (return t))))
-                       ; not found - is :allow-other-keys t in rest of user args
-                       (when (not (do ((remargs kargs (cddr remargs)))
-                                      ((null remargs) nil)
-                                    (when (and (eq (car remargs) :allow-other-keys)
-                                               (cadr remargs))
-                                      (setq aok t)
-                                      (return t))))              
-                         (bad-key-error key vector-arg (collect-lexpr-args args key-index args-len))))))))
+                 (unless (%cadr (%pl-search (nthcdr key-index args) :allow-other-keys))
+                   (do ((i key-index (+ i 2))
+                        (kargs (nthcdr key-index args) (cddr kargs)))
+                       ((eq i args-len))
+                     (declare (fixnum i))
+                     (let ((key (car kargs)))
+                       (when (not (or (eq key :allow-other-keys)
+                                      (dotimes (i keyvect-len nil)
+                                        (if (eq key (%svref keyvect i))
+                                          (return t)))))
+                         (bad-key-error key vector-arg (collect-lexpr-args args key-index args-len))
+                         ))))))
              (let ((method (%svref vector-arg 2)))
-               ; magic here ?? not needed
+                                        ; magic here ?? not needed
                (apply method args)))))
     (if (listp args)
@@ -995 +985 @@
       (with-list-from-lexpr (args-list args)
         (do-it vector-arg args-list)))))
-|#
-
-(defun %%check-keywords (vector-arg args)
-  (let ((method (%svref vector-arg 2)))
-    (if (listp args)
-      (apply method args)
-      (%apply-lexpr-tail-wise method args))))
+
+
+