X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fdlisp2.lisp;h=504c540ba2f260e9c2abf15cc8ca76a21ddcdda8;hb=96a67b487909638cc0cb91114b6babf94b4bc1a7;hp=8c5e787a4dada2dbd8c68fc0fd02d5e380d6a3cc;hpb=a530bbe337109d898d5b4a001fc8f1afa3b5dc39;p=sbcl.git diff --git a/src/pcl/dlisp2.lisp b/src/pcl/dlisp2.lisp index 8c5e787..504c540 100644 --- a/src/pcl/dlisp2.lisp +++ b/src/pcl/dlisp2.lisp @@ -22,27 +22,31 @@ ;;;; specification. (in-package "SB-PCL") - -(sb-int:file-comment - "$Header$") (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 @@ -50,37 +54,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")) @@ -88,42 +87,42 @@ (cached-emf-p return-value-p metatypes applyp) (declare (ignore applyp)) (if cached-emf-p - #'(lambda (cache 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 ((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)))))))))) + (lambda (cache miss-fn) + (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)))))))) + (lambda (cache emf miss-fn) + (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)) + (values (lambda (emf) + (lambda (&rest args) + (invoke-emf emf args))) + t))