X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fdfun.lisp;h=0d622a888253fa6a4603352187dedf1373441e01;hb=d5aafdd8ab6387e12bac187048ed322bc96fb79a;hp=f2142c896095b9c3534f57baf9f6991a364ad14a;hpb=a530bbe337109d898d5b4a001fc8f1afa3b5dc39;p=sbcl.git diff --git a/src/pcl/dfun.lisp b/src/pcl/dfun.lisp index f2142c8..0d622a8 100644 --- a/src/pcl/dfun.lisp +++ b/src/pcl/dfun.lisp @@ -22,9 +22,6 @@ ;;;; specification. (in-package "SB-PCL") - -(sb-int:file-comment - "$Header$") #| @@ -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))))))))))) ;;; 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)) @@ -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)