X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fdlisp2.lisp;h=538c78156a234d9ef779f5aaa196fd99f8dd759c;hb=9be48f2a73ca5f4cc0848b8c0adad7127de10373;hp=b192fe64f5b1f490d148dc8195b2fc0e170e7a30;hpb=ed7ba4dad8a79726fdfeba5aa12e276ea852c540;p=sbcl.git diff --git a/src/pcl/dlisp2.lisp b/src/pcl/dlisp2.lisp index b192fe6..538c781 100644 --- a/src/pcl/dlisp2.lisp +++ b/src/pcl/dlisp2.lisp @@ -22,24 +22,35 @@ ;;;; specification. (in-package "SB-PCL") + +;;;; The whole of this file is dead code as long as *optimize-cache-functions-p* +;;;; is true, which it currently _always_ is. + (defun emit-reader/writer-function (reader/writer 1-or-2-class class-slot-p) (values (ecase reader/writer (:reader (ecase 1-or-2-class - (1 (if class-slot-p - (emit-reader/writer-macro :reader 1 t) - (emit-reader/writer-macro :reader 1 nil))) - (2 (if class-slot-p - (emit-reader/writer-macro :reader 2 t) - (emit-reader/writer-macro :reader 2 nil))))) + (1 (if class-slot-p + (emit-reader/writer-macro :reader 1 t) + (emit-reader/writer-macro :reader 1 nil))) + (2 (if class-slot-p + (emit-reader/writer-macro :reader 2 t) + (emit-reader/writer-macro :reader 2 nil))))) (:writer (ecase 1-or-2-class - (1 (if class-slot-p - (emit-reader/writer-macro :writer 1 t) - (emit-reader/writer-macro :writer 1 nil))) - (2 (if class-slot-p - (emit-reader/writer-macro :writer 2 t) - (emit-reader/writer-macro :writer 2 nil)))))) + (1 (if class-slot-p + (emit-reader/writer-macro :writer 1 t) + (emit-reader/writer-macro :writer 1 nil))) + (2 (if class-slot-p + (emit-reader/writer-macro :writer 2 t) + (emit-reader/writer-macro :writer 2 nil))))) + (:boundp (ecase 1-or-2-class + (1 (if class-slot-p + (emit-reader/writer-macro :boundp 1 t) + (emit-reader/writer-macro :boundp 1 nil))) + (2 (if class-slot-p + (emit-reader/writer-macro :boundp 2 t) + (emit-reader/writer-macro :boundp 2 nil)))))) nil)) (defun emit-one-or-n-index-reader/writer-function @@ -47,37 +58,32 @@ (values (ecase reader/writer (:reader (if cached-index-p - (if class-slot-p - (emit-one-or-n-index-reader/writer-macro :reader t t) - (emit-one-or-n-index-reader/writer-macro :reader t nil)) - (if class-slot-p - (emit-one-or-n-index-reader/writer-macro :reader nil t) - (emit-one-or-n-index-reader/writer-macro :reader nil nil)))) + (if class-slot-p + (emit-one-or-n-index-reader/writer-macro :reader t t) + (emit-one-or-n-index-reader/writer-macro :reader t nil)) + (if class-slot-p + (emit-one-or-n-index-reader/writer-macro :reader nil t) + (emit-one-or-n-index-reader/writer-macro :reader nil nil)))) (:writer (if cached-index-p - (if class-slot-p - (emit-one-or-n-index-reader/writer-macro :writer t t) - (emit-one-or-n-index-reader/writer-macro :writer t nil)) - (if class-slot-p - (emit-one-or-n-index-reader/writer-macro :writer nil t) - (emit-one-or-n-index-reader/writer-macro :writer nil nil))))) + (if class-slot-p + (emit-one-or-n-index-reader/writer-macro :writer t t) + (emit-one-or-n-index-reader/writer-macro :writer t nil)) + (if class-slot-p + (emit-one-or-n-index-reader/writer-macro :writer nil t) + (emit-one-or-n-index-reader/writer-macro :writer nil nil)))) + (:boundp (if cached-index-p + (if class-slot-p + (emit-one-or-n-index-reader/writer-macro :boundp t t) + (emit-one-or-n-index-reader/writer-macro :boundp t nil)) + (if class-slot-p + (emit-one-or-n-index-reader/writer-macro :boundp nil t) + (emit-one-or-n-index-reader/writer-macro :boundp nil nil))))) nil)) -;;; Note this list is setup in dlisp3.lisp when all the necessary -;;; macros have been loaded. -(defvar *checking-or-caching-function-list* nil) - -(defmacro emit-checking-or-caching-function-precompiled () - `(cdr (assoc (list cached-emf-p return-value-p metatypes applyp) - *checking-or-caching-function-list* - :test #'equal))) - (defun emit-checking-or-caching-function (cached-emf-p return-value-p metatypes applyp) - (let ((fn (emit-checking-or-caching-function-precompiled))) - (if fn - (values fn nil) - (values (emit-checking-or-caching-function-preliminary - cached-emf-p return-value-p metatypes applyp) - t)))) + (values (emit-checking-or-caching-function-preliminary + cached-emf-p return-value-p metatypes applyp) + t)) (defvar *not-in-cache* (make-symbol "not in cache")) @@ -86,41 +92,41 @@ (declare (ignore applyp)) (if cached-emf-p (lambda (cache miss-fn) - (declare (type function miss-fn)) - #'(sb-kernel:instance-lambda (&rest args) + (declare (type function miss-fn)) + #'(lambda (&rest args) (declare #.*optimize-speed*) - (with-dfun-wrappers (args metatypes) - (dfun-wrappers invalid-wrapper-p) - (apply miss-fn args) - (if invalid-wrapper-p - (apply miss-fn args) - (let ((emf (probe-cache cache dfun-wrappers *not-in-cache*))) - (if (eq emf *not-in-cache*) - (apply miss-fn args) - (if return-value-p - emf - (invoke-emf emf args)))))))) + (with-dfun-wrappers (args metatypes) + (dfun-wrappers invalid-wrapper-p) + (apply miss-fn args) + (if invalid-wrapper-p + (apply miss-fn args) + (let ((emf (probe-cache cache dfun-wrappers *not-in-cache*))) + (if (eq emf *not-in-cache*) + (apply miss-fn args) + (if return-value-p + emf + (invoke-emf emf args)))))))) (lambda (cache emf miss-fn) - (declare (type function miss-fn)) - #'(sb-kernel:instance-lambda (&rest args) - (declare #.*optimize-speed*) - (with-dfun-wrappers (args metatypes) - (dfun-wrappers invalid-wrapper-p) - (apply miss-fn args) - (if invalid-wrapper-p - (apply miss-fn args) - (let ((found-p (not (eq *not-in-cache* - (probe-cache cache dfun-wrappers - *not-in-cache*))))) - (if found-p - (invoke-emf emf args) - (if return-value-p - t - (apply miss-fn args)))))))))) + (declare (type function miss-fn)) + #'(lambda (&rest args) + (declare #.*optimize-speed*) + (with-dfun-wrappers (args metatypes) + (dfun-wrappers invalid-wrapper-p) + (apply miss-fn args) + (if invalid-wrapper-p + (apply miss-fn args) + (let ((found-p (not (eq *not-in-cache* + (probe-cache cache dfun-wrappers + *not-in-cache*))))) + (if found-p + (invoke-emf emf args) + (if return-value-p + t + (apply miss-fn args)))))))))) (defun emit-default-only-function (metatypes applyp) (declare (ignore metatypes applyp)) (values (lambda (emf) - (lambda (&rest args) - (invoke-emf emf args))) - t)) + (lambda (&rest args) + (invoke-emf emf args))) + t))