0.9.10.30
[sbcl.git] / src / pcl / dlisp2.lisp
1 ;;;; This software is part of the SBCL system. See the README file for
2 ;;;; more information.
3
4 ;;;; This software is derived from software originally released by Xerox
5 ;;;; Corporation. Copyright and release statements follow. Later modifications
6 ;;;; to the software are in the public domain and are provided with
7 ;;;; absolutely no warranty. See the COPYING and CREDITS files for more
8 ;;;; information.
9
10 ;;;; copyright information from original PCL sources:
11 ;;;;
12 ;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
13 ;;;; All rights reserved.
14 ;;;;
15 ;;;; Use and copying of this software and preparation of derivative works based
16 ;;;; upon this software are permitted. Any distribution of this software or
17 ;;;; derivative works must comply with all applicable United States export
18 ;;;; control laws.
19 ;;;;
20 ;;;; This software is made available AS IS, and Xerox Corporation makes no
21 ;;;; warranty about the software, its performance or its conformity to any
22 ;;;; specification.
23
24 (in-package "SB-PCL")
25 \f
26 (defun emit-reader/writer-function (reader/writer 1-or-2-class class-slot-p)
27   (values
28    (ecase reader/writer
29      (:reader (ecase 1-or-2-class
30                 (1 (if class-slot-p
31                        (emit-reader/writer-macro :reader 1 t)
32                        (emit-reader/writer-macro :reader 1 nil)))
33                 (2 (if class-slot-p
34                        (emit-reader/writer-macro :reader 2 t)
35                        (emit-reader/writer-macro :reader 2 nil)))))
36      (:writer (ecase 1-or-2-class
37                 (1 (if class-slot-p
38                        (emit-reader/writer-macro :writer 1 t)
39                        (emit-reader/writer-macro :writer 1 nil)))
40                 (2 (if class-slot-p
41                        (emit-reader/writer-macro :writer 2 t)
42                        (emit-reader/writer-macro :writer 2 nil)))))
43      (:boundp (ecase 1-or-2-class
44                 (1 (if class-slot-p
45                        (emit-reader/writer-macro :boundp 1 t)
46                        (emit-reader/writer-macro :boundp 1 nil)))
47                 (2 (if class-slot-p
48                        (emit-reader/writer-macro :boundp 2 t)
49                        (emit-reader/writer-macro :boundp 2 nil))))))
50    nil))
51
52 (defun emit-one-or-n-index-reader/writer-function
53     (reader/writer cached-index-p class-slot-p)
54   (values
55    (ecase reader/writer
56      (:reader (if cached-index-p
57                   (if class-slot-p
58                       (emit-one-or-n-index-reader/writer-macro :reader t t)
59                       (emit-one-or-n-index-reader/writer-macro :reader t nil))
60                   (if class-slot-p
61                       (emit-one-or-n-index-reader/writer-macro :reader nil t)
62                       (emit-one-or-n-index-reader/writer-macro :reader nil nil))))
63      (:writer (if cached-index-p
64                   (if class-slot-p
65                       (emit-one-or-n-index-reader/writer-macro :writer t t)
66                       (emit-one-or-n-index-reader/writer-macro :writer t nil))
67                   (if class-slot-p
68                       (emit-one-or-n-index-reader/writer-macro :writer nil t)
69                       (emit-one-or-n-index-reader/writer-macro :writer nil nil))))
70      (:boundp (if cached-index-p
71                   (if class-slot-p
72                       (emit-one-or-n-index-reader/writer-macro :boundp t t)
73                       (emit-one-or-n-index-reader/writer-macro :boundp t nil))
74                   (if class-slot-p
75                       (emit-one-or-n-index-reader/writer-macro :boundp nil t)
76                       (emit-one-or-n-index-reader/writer-macro :boundp nil nil)))))
77    nil))
78
79 (defun emit-checking-or-caching-function (cached-emf-p return-value-p metatypes applyp)
80   (values (emit-checking-or-caching-function-preliminary
81            cached-emf-p return-value-p metatypes applyp)
82           t))
83
84 (defvar *not-in-cache* (make-symbol "not in cache"))
85
86 (defun emit-checking-or-caching-function-preliminary
87     (cached-emf-p return-value-p metatypes applyp)
88   (declare (ignore applyp))
89   (if cached-emf-p
90       (lambda (cache miss-fn)
91         (declare (type function miss-fn))
92         #'(lambda (&rest args)
93             (declare #.*optimize-speed*)
94             (with-dfun-wrappers (args metatypes)
95               (dfun-wrappers invalid-wrapper-p)
96               (apply miss-fn args)
97               (if invalid-wrapper-p
98                   (apply miss-fn args)
99                   (let ((emf (probe-cache cache dfun-wrappers *not-in-cache*)))
100                     (if (eq emf *not-in-cache*)
101                         (apply miss-fn args)
102                         (if return-value-p
103                             emf
104                             (invoke-emf emf args))))))))
105       (lambda (cache emf miss-fn)
106         (declare (type function miss-fn))
107         #'(lambda (&rest args)
108             (declare #.*optimize-speed*)
109             (with-dfun-wrappers (args metatypes)
110               (dfun-wrappers invalid-wrapper-p)
111               (apply miss-fn args)
112               (if invalid-wrapper-p
113                   (apply miss-fn args)
114                   (let ((found-p (not (eq *not-in-cache*
115                                           (probe-cache cache dfun-wrappers
116                                                        *not-in-cache*)))))
117                     (if found-p
118                         (invoke-emf emf args)
119                         (if return-value-p
120                             t
121                             (apply miss-fn args))))))))))
122
123 (defun emit-default-only-function (metatypes applyp)
124   (declare (ignore metatypes applyp))
125   (values (lambda (emf)
126             (lambda (&rest args)
127               (invoke-emf emf args)))
128           t))