0.6.10.21:

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

diff --git a/src/pcl/dfun.lisp b/src/pcl/dfun.lisp
index f2142c8..0d622a8 100644 (file)
--- a/src/pcl/dfun.lisp
+++ b/src/pcl/dfun.lisp
@@ -22,9 +22,6 @@
 ;;;; specification.
 
 (in-package "SB-PCL")
-
-(sb-int:file-comment
-  "$Header$")
 \f
 #|
 
@@ -107,7 +104,7 @@ And so, we are saved.
             (member generator '(emit-checking emit-caching
                                 emit-in-checking-cache-p emit-constant-value)))
     (setq args (cons (mapcar #'(lambda (mt)
-                                (if (eq mt 't)
+                                (if (eq mt t)
                                     mt
                                     'class))
                             (car args))
@@ -115,7 +112,7 @@ And so, we are saved.
   (let* ((generator-entry (assq generator *dfun-constructors*))
         (args-entry (assoc args (cdr generator-entry) :test #'equal)))
     (if (null *enable-dfun-constructor-caching*)
-       (apply (symbol-function generator) args)
+       (apply (fdefinition generator) args)
        (or (cadr args-entry)
            (multiple-value-bind (new not-best-p)
                (apply (symbol-function generator) args)
@@ -164,15 +161,12 @@ And so, we are saved.
                         (eq (caddr args-entry) system))
                 (when system (setf (caddr args-entry) system))
                 (gather1
-                  (make-top-level-form `(precompile-dfun-constructor
-                                         ,(car generator-entry))
-                                       '(:load-toplevel)
-                    `(load-precompiled-dfun-constructor
-                      ',(car generator-entry)
-                      ',(car args-entry)
-                      ',system
-                      ,(apply (symbol-function (car generator-entry))
-                              (car args-entry))))))))))))
+                  `(load-precompiled-dfun-constructor
+                    ',(car generator-entry)
+                    ',(car args-entry)
+                    ',system
+                    ,(apply (fdefinition (car generator-entry))
+                            (car args-entry)))))))))))
 \f
 ;;; When all the methods of a generic function are automatically generated
 ;;; reader or writer methods a number of special optimizations are possible.
@@ -303,13 +297,11 @@ And so, we are saved.
 (defun accessor-miss-function (gf dfun-info)
   (ecase (dfun-info-accessor-type dfun-info)
     (reader
-      #'(lambda (arg)
-          (declare (pcl-fast-call))
-          (accessor-miss gf nil arg dfun-info)))
+     (lambda (arg)
+       (accessor-miss gf nil arg dfun-info)))
     (writer
-     #'(lambda (new arg)
-        (declare (pcl-fast-call))
-        (accessor-miss gf new arg dfun-info)))))
+     (lambda (new arg)
+       (accessor-miss gf new arg dfun-info)))))
 
 #-sb-fluid (declaim (sb-ext:freeze-type dfun-info))
 \f
@@ -382,7 +374,7 @@ And so, we are saved.
   (multiple-value-bind (nreq applyp metatypes nkeys)
       (get-generic-function-info generic-function)
     (declare (ignore nreq))
-    (if (every #'(lambda (mt) (eq mt 't)) metatypes)
+    (if (every #'(lambda (mt) (eq mt t)) metatypes)
        (let ((dfun-info (default-method-only-dfun-info)))
          (values
           (funcall (get-dfun-constructor 'emit-default-only metatypes applyp)
@@ -395,16 +387,15 @@ And so, we are saved.
           (funcall (get-dfun-constructor 'emit-checking metatypes applyp)
                    cache
                    function
-                   #'(lambda (&rest args)
-                       (declare (pcl-fast-call))
-                       (checking-miss generic-function args dfun-info)))
+                   (lambda (&rest args)
+                     (checking-miss generic-function args dfun-info)))
           cache
           dfun-info)))))
 
 (defun make-final-checking-dfun (generic-function function
                                                  classes-list new-class)
   (let ((metatypes (arg-info-metatypes (gf-arg-info generic-function))))
-    (if (every #'(lambda (mt) (eq mt 't)) metatypes)
+    (if (every #'(lambda (mt) (eq mt t)) metatypes)
        (values #'(lambda (&rest args)
                    (invoke-emf function args))
                nil (default-method-only-dfun-info))
@@ -417,7 +408,7 @@ And so, we are saved.
   (multiple-value-bind (nreq applyp metatypes nkeys)
       (get-generic-function-info generic-function)
     (declare (ignore nreq applyp nkeys))
-    (every #'(lambda (mt) (eq mt 't)) metatypes)))
+    (every #'(lambda (mt) (eq mt t)) metatypes)))
 
 (defun use-caching-dfun-p (generic-function)
   (some (lambda (method)
@@ -453,9 +444,8 @@ And so, we are saved.
       (values
        (funcall (get-dfun-constructor 'emit-caching metatypes applyp)
                cache
-               #'(lambda (&rest args)
-                   (declare (pcl-fast-call))
-                   (caching-miss generic-function args dfun-info)))
+               (lambda (&rest args)
+                 (caching-miss generic-function args dfun-info)))
        cache
        dfun-info))))
 
@@ -475,7 +465,7 @@ And so, we are saved.
     (when (and metatypes
               (not (null (car metatypes)))
               (dolist (mt metatypes nil)
-                (unless (eq mt 't) (return t))))
+                (unless (eq mt t) (return t))))
       (get-dfun-constructor 'emit-caching metatypes applyp))))
 
 (defun use-constant-value-dfun-p (gf &optional boolean-values-p)
@@ -501,7 +491,7 @@ And so, we are saved.
                                                 (method-function method)))
                                         :constant-value default)))
                             (if boolean-values-p
-                                (not (or (eq value 't) (eq value nil)))
+                                (not (or (eq value t) (eq value nil)))
                                 (eq value default)))))
                   methods)))))
 
@@ -514,9 +504,8 @@ And so, we are saved.
       (values
        (funcall (get-dfun-constructor 'emit-constant-value metatypes)
                cache
-               #'(lambda (&rest args)
-                   (declare (pcl-fast-call))
-                   (constant-value-miss generic-function args dfun-info)))
+               (lambda (&rest args)
+                 (constant-value-miss generic-function args dfun-info)))
        cache
        dfun-info))))
 
@@ -733,12 +722,12 @@ And so, we are saved.
     (ecase type
       (reader #'(sb-kernel:instance-lambda (instance)
                  (let* ((class (class-of instance))
-                        (class-name (bootstrap-get-slot 'class class 'name)))
-                   (bootstrap-get-slot class-name instance slot-name))))
+                        (class-name (!bootstrap-get-slot 'class class 'name)))
+                   (!bootstrap-get-slot class-name instance slot-name))))
       (writer #'(sb-kernel:instance-lambda (new-value instance)
                  (let* ((class (class-of instance))
-                        (class-name (bootstrap-get-slot 'class class 'name)))
-                   (bootstrap-set-slot class-name instance slot-name new-value)))))))
+                        (class-name (!bootstrap-get-slot 'class class 'name)))
+                   (!bootstrap-set-slot class-name instance slot-name new-value)))))))
 
 (defun initial-dfun (gf args)
   (dfun-miss (gf args wrappers invalidp nemf ntype nindex)
@@ -1130,7 +1119,7 @@ And so, we are saved.
                 (dolist (sclass (if early-p
                                    (early-class-precedence-list class)
                                    (class-precedence-list class))
-                         (error "This can't happen"))
+                         (error "This can't happen."))
                   (let ((a (assq sclass specl+slotd-list)))
                     (when a
                       (let* ((slotd (cdr a))
@@ -1208,10 +1197,10 @@ And so, we are saved.
 (defun order-specializers (specl1 specl2 index compare-classes-function)
   (let ((type1 (if (eq *boot-state* 'complete)
                   (specializer-type specl1)
-                  (bootstrap-get-slot 'specializer specl1 'type)))
+                  (!bootstrap-get-slot 'specializer specl1 'type)))
        (type2 (if (eq *boot-state* 'complete)
                   (specializer-type specl2)
-                  (bootstrap-get-slot 'specializer specl2 'type))))
+                  (!bootstrap-get-slot 'specializer specl2 'type))))
     (cond ((eq specl1 specl2)
           nil)
          ((atom type1)
@@ -1389,11 +1378,11 @@ And so, we are saved.
 
 (defun specializer-applicable-using-type-p (specl type)
   (setq specl (type-from-specializer specl))
-  (when (eq specl 't)
+  (when (eq specl t)
     (return-from specializer-applicable-using-type-p (values t t)))
   ;; This is used by c-a-m-u-t and generate-discrimination-net-internal,
   ;; and has only what they need.
-  (if (or (atom type) (eq (car type) 't))
+  (if (or (atom type) (eq (car type) t))
       (values nil t)
       (case (car type)
        (and    (saut-and specl type))
@@ -1406,7 +1395,7 @@ And so, we are saved.
                           'specializer-applicable-using-type-p
                           type)))))
 
-(defun map-all-classes (function &optional (root 't))
+(defun map-all-classes (function &optional (root t))
   (let ((braid-p (or (eq *boot-state* 'braid)
                     (eq *boot-state* 'complete))))
     (labels ((do-class (class)
@@ -1507,7 +1496,7 @@ And so, we are saved.
 (defun update-dfun (generic-function &optional dfun cache info)
   (let* ((early-p (early-gf-p generic-function))
         (gf-name (if early-p
-                     (early-gf-name generic-function)
+                     (!early-gf-name generic-function)
                      (generic-function-name generic-function)))
         (ocache (gf-dfun-cache generic-function)))
     (set-dfun generic-function dfun cache info)