0.7.8.53:

[sbcl.git] / src / pcl / boot.lisp

diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp
index 1c9b4fe..d9c76b1 100644 (file)
--- a/src/pcl/boot.lisp
+++ b/src/pcl/boot.lisp
@@ -78,15 +78,6 @@ bootstrapping.
 ;;; then things break.)
 (declaim (declaration class))
 
-;;; FIXME: SB-KERNEL::PCL-CHECK-WRAPPER-VALIDITY-HOOK shouldn't be a
-;;; separate function. Instead, we should define a simple placeholder
-;;; version of SB-PCL:CHECK-WRAPPER-VALIDITY where
-;;; SB-KERNEL::PCL-CHECK-WRAPPER-VALIDITY is defined now, then just
-;;; let the later real PCL DEFUN of SB-PCL:CHECK-WRAPPER-VALIDITY
-;;; overwrite it.
-(setf (symbol-function 'sb-kernel::pcl-check-wrapper-validity-hook)
-      #'check-wrapper-validity)
-
 (declaim (notinline make-a-method
                    add-named-method
                    ensure-generic-function-using-class
@@ -1097,8 +1088,9 @@ bootstrapping.
                                                      ,(cadr var)))))))
                   (rest `((,var ,args-tail)))
                   (key (cond ((not (consp var))
-                              `((,var (get-key-arg ,(keywordicate var)
-                                                   ,args-tail))))
+                              `((,var (car
+                                       (get-key-arg-tail ,(keywordicate var)
+                                                         ,args-tail)))))
                              ((null (cddr var))
                               (multiple-value-bind (keyword variable)
                                   (if (consp (car var))
@@ -1106,8 +1098,9 @@ bootstrapping.
                                               (cadar var))
                                       (values (keywordicate (car var))
                                               (car var)))
-                                `((,key (get-key-arg1 ',keyword ,args-tail))
-                                  (,variable (if (consp ,key)
+                                `((,key (get-key-arg-tail ',keyword
+                                                          ,args-tail))
+                                  (,variable (if ,key
                                                  (car ,key)
                                                  ,(cadr var))))))
                              (t
@@ -1117,9 +1110,10 @@ bootstrapping.
                                               (cadar var))
                                       (values (keywordicate (car var))
                                               (car var)))
-                                `((,key (get-key-arg1 ',keyword ,args-tail))
+                                `((,key (get-key-arg-tail ',keyword
+                                                          ,args-tail))
                                   (,(caddr var) ,key)
-                                  (,variable (if (consp ,key)
+                                  (,variable (if ,key
                                                  (car ,key)
                                                  ,(cadr var))))))))
                   (aux `(,var))))))
@@ -1129,15 +1123,14 @@ bootstrapping.
           (declare (ignorable ,args-tail))
           ,@body)))))
 
-(defun get-key-arg (keyword list)
-  (loop (when (atom list) (return nil))
-       (when (eq (car list) keyword) (return (cadr list)))
-       (setq list (cddr list))))
-
-(defun get-key-arg1 (keyword list)
-  (loop (when (atom list) (return nil))
-       (when (eq (car list) keyword) (return (cdr list)))
-       (setq list (cddr list))))
+(defun get-key-arg-tail (keyword list)
+  (loop for (key . tail) on list by #'cddr
+       when (null tail) do
+         ;; FIXME: Do we want to export this symbol? Or maybe use an
+         ;; (ERROR 'SIMPLE-PROGRAM-ERROR) form?
+         (sb-c::%odd-key-args-error)
+       when (eq key keyword)
+         return tail))
 
 (defun walk-method-lambda (method-lambda required-parameters env slots calls)
   (let ((call-next-method-p nil)   ; flag indicating that CALL-NEXT-METHOD
@@ -1715,13 +1708,15 @@ bootstrapping.
 (defun ensure-generic-function-using-class (existing spec &rest keys
                                            &key (lambda-list nil
                                                              lambda-list-p)
+                                           argument-precedence-order
                                            &allow-other-keys)
   (declare (ignore keys))
   (cond ((and existing (early-gf-p existing))
         existing)
        ((assoc spec *!generic-function-fixups* :test #'equal)
         (if existing
-            (make-early-gf spec lambda-list lambda-list-p existing)
+            (make-early-gf spec lambda-list lambda-list-p existing
+                           argument-precedence-order)
             (error "The function ~S is not already defined." spec)))
        (existing
         (error "~S should be on the list ~S."
@@ -1729,9 +1724,11 @@ bootstrapping.
                '*!generic-function-fixups*))
        (t
         (pushnew spec *!early-generic-functions* :test #'equal)
-        (make-early-gf spec lambda-list lambda-list-p))))
+        (make-early-gf spec lambda-list lambda-list-p nil
+                       argument-precedence-order))))
 
-(defun make-early-gf (spec &optional lambda-list lambda-list-p function)
+(defun make-early-gf (spec &optional lambda-list lambda-list-p
+                     function argument-precedence-order)
   (let ((fin (allocate-funcallable-instance *sgf-wrapper* *sgf-slots-init*)))
     (set-funcallable-instance-fun
      fin
@@ -1755,7 +1752,11 @@ bootstrapping.
       (setf (early-gf-arg-info fin) arg-info)
       (when lambda-list-p
        (proclaim (defgeneric-declaration spec lambda-list))
-       (set-arg-info fin :lambda-list lambda-list)))
+       (if argument-precedence-order
+           (set-arg-info fin
+                         :lambda-list lambda-list
+                         :argument-precedence-order argument-precedence-order)
+           (set-arg-info fin :lambda-list lambda-list))))
     fin))
 
 (defun set-dfun (gf &optional dfun cache info)