1 |
|
;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*- |
2 |
|
;;; |
3 |
|
;;; ************************************************************************* |
4 |
|
;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. |
5 |
|
;;; All rights reserved. |
6 |
|
;;; |
7 |
|
;;; Use and copying of this software and preparation of derivative works |
8 |
|
;;; based upon this software are permitted. Any distribution of this |
9 |
|
;;; software or derivative works must comply with all applicable United |
10 |
|
;;; States export control laws. |
11 |
|
;;; |
12 |
|
;;; This software is made available AS IS, and Xerox Corporation makes no |
13 |
|
;;; warranty about the software, its performance or its conformity to any |
14 |
|
;;; specification. |
15 |
|
;;; |
16 |
|
;;; Any person obtaining a copy of this software is requested to send their |
17 |
|
;;; name and post office or electronic mail address to: |
18 |
|
;;; CommonLoops Coordinator |
19 |
|
;;; Xerox PARC |
20 |
|
;;; 3333 Coyote Hill Rd. |
21 |
|
;;; Palo Alto, CA 94304 |
22 |
|
;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) |
23 |
|
;;; |
24 |
|
;;; Suggestions, comments and requests for improvements are also welcome. |
25 |
|
;;; ************************************************************************* |
26 |
|
;;; |
27 |
|
|
28 |
|
(in-package :pcl) |
29 |
|
|
30 |
|
(defun emit-reader/writer-function (reader/writer 1-or-2-class class-slot-p) |
31 |
|
(values |
32 |
|
(ecase reader/writer |
33 |
|
(:reader (ecase 1-or-2-class |
34 |
|
(1 (if class-slot-p |
35 |
|
(emit-reader/writer-macro :reader 1 t) |
36 |
|
(emit-reader/writer-macro :reader 1 nil))) |
37 |
|
(2 (if class-slot-p |
38 |
|
(emit-reader/writer-macro :reader 2 t) |
39 |
|
(emit-reader/writer-macro :reader 2 nil))))) |
40 |
|
(:writer (ecase 1-or-2-class |
41 |
|
(1 (if class-slot-p |
42 |
|
(emit-reader/writer-macro :writer 1 t) |
43 |
|
(emit-reader/writer-macro :writer 1 nil))) |
44 |
|
(2 (if class-slot-p |
45 |
|
(emit-reader/writer-macro :writer 2 t) |
46 |
|
(emit-reader/writer-macro :writer 2 nil)))))) |
47 |
|
nil)) |
48 |
|
|
49 |
|
(defun emit-one-or-n-index-reader/writer-function |
50 |
|
(reader/writer cached-index-p class-slot-p) |
51 |
|
(values |
52 |
|
(ecase reader/writer |
53 |
|
(:reader (if cached-index-p |
54 |
|
(if class-slot-p |
55 |
|
(emit-one-or-n-index-reader/writer-macro :reader t t) |
56 |
|
(emit-one-or-n-index-reader/writer-macro :reader t nil)) |
57 |
|
(if class-slot-p |
58 |
|
(emit-one-or-n-index-reader/writer-macro :reader nil t) |
59 |
|
(emit-one-or-n-index-reader/writer-macro :reader nil nil)))) |
60 |
|
(:writer (if cached-index-p |
61 |
|
(if class-slot-p |
62 |
|
(emit-one-or-n-index-reader/writer-macro :writer t t) |
63 |
|
(emit-one-or-n-index-reader/writer-macro :writer t nil)) |
64 |
|
(if class-slot-p |
65 |
|
(emit-one-or-n-index-reader/writer-macro :writer nil t) |
66 |
|
(emit-one-or-n-index-reader/writer-macro :writer nil nil))))) |
67 |
|
nil)) |
68 |
|
|
69 |
|
(eval-when (compile load eval) |
70 |
|
(defparameter checking-or-caching-list |
71 |
|
'() |
72 |
|
#|| |
73 |
|
'((T NIL (CLASS) NIL) |
74 |
|
(T NIL (CLASS CLASS) NIL) |
75 |
|
(T NIL (CLASS CLASS CLASS) NIL) |
76 |
|
(T NIL (CLASS CLASS T) NIL) |
77 |
|
(T NIL (CLASS CLASS T T) NIL) |
78 |
|
(T NIL (CLASS CLASS T T T) NIL) |
79 |
|
(T NIL (CLASS T) NIL) |
80 |
|
(T NIL (CLASS T T) NIL) |
81 |
|
(T NIL (CLASS T T T) NIL) |
82 |
|
(T NIL (CLASS T T T T) NIL) |
83 |
|
(T NIL (CLASS T T T T T) NIL) |
84 |
|
(T NIL (CLASS T T T T T T) NIL) |
85 |
|
(T NIL (T CLASS) NIL) |
86 |
|
(T NIL (T CLASS T) NIL) |
87 |
|
(T NIL (T T CLASS) NIL) |
88 |
|
(T NIL (CLASS) T) |
89 |
|
(T NIL (CLASS CLASS) T) |
90 |
|
(T NIL (CLASS T) T) |
91 |
|
(T NIL (CLASS T T) T) |
92 |
|
(T NIL (CLASS T T T) T) |
93 |
|
(T NIL (T CLASS) T) |
94 |
|
(T T (CLASS) NIL) |
95 |
|
(T T (CLASS CLASS) NIL) |
96 |
|
(T T (CLASS CLASS CLASS) NIL) |
97 |
|
(NIL NIL (CLASS) NIL) |
98 |
|
(NIL NIL (CLASS CLASS) NIL) |
99 |
|
(NIL NIL (CLASS CLASS T) NIL) |
100 |
|
(NIL NIL (CLASS CLASS T T) NIL) |
101 |
|
(NIL NIL (CLASS T) NIL) |
102 |
|
(NIL NIL (T CLASS T) NIL) |
103 |
|
(NIL NIL (CLASS) T) |
104 |
|
(NIL NIL (CLASS CLASS) T)) ||# )) |
105 |
|
|
106 |
|
(defmacro make-checking-or-caching-function-list () |
107 |
|
`(list ,@(mapcar #'(lambda (key) |
108 |
|
`(cons ',key (emit-checking-or-caching-macro ,@key))) |
109 |
|
checking-or-caching-list))) |
110 |
|
|
111 |
|
(defvar checking-or-caching-function-list) |
112 |
|
|
113 |
|
(defun initialize-checking-or-caching-function-list () |
114 |
|
(setq checking-or-caching-function-list |
115 |
|
(make-checking-or-caching-function-list))) |
116 |
|
|
117 |
|
(initialize-checking-or-caching-function-list) |
118 |
|
|
119 |
|
(defmacro emit-checking-or-caching-function-precompiled () |
120 |
|
`(cdr (assoc (list cached-emf-p return-value-p metatypes applyp) |
121 |
|
checking-or-caching-function-list |
122 |
|
:test #'equal))) |
123 |
|
|
124 |
|
(defun emit-checking-or-caching-function (cached-emf-p return-value-p metatypes applyp) |
125 |
|
(let ((fn (emit-checking-or-caching-function-precompiled))) |
126 |
|
(if fn |
127 |
|
(values fn nil) |
128 |
|
(values (emit-checking-or-caching-function-preliminary |
129 |
|
cached-emf-p return-value-p metatypes applyp) |
130 |
|
t)))) |
131 |
|
|
132 |
|
(defvar not-in-cache (make-symbol "not in cache")) |
133 |
|
|
134 |
|
(defun emit-checking-or-caching-function-preliminary |
135 |
|
(cached-emf-p return-value-p metatypes applyp) |
136 |
|
(declare (ignore applyp)) |
137 |
|
(if cached-emf-p |
138 |
|
#'(lambda (cache miss-fn) |
139 |
|
(declare (type function miss-fn)) |
140 |
|
(fin-lambda-fn (&rest args) |
141 |
|
(declare #.*optimize-speed*) |
142 |
|
#+copy-&rest-arg (setq args (copy-list args)) |
143 |
|
(with-dfun-wrappers (args metatypes) (dfun-wrappers invalid-wrapper-p) |
144 |
|
(apply miss-fn args) |
145 |
|
(if invalid-wrapper-p |
146 |
|
(apply miss-fn args) |
147 |
|
(let ((emf (probe-cache cache dfun-wrappers not-in-cache))) |
148 |
|
(if (eq emf not-in-cache) |
149 |
|
(apply miss-fn args) |
150 |
|
(if return-value-p |
151 |
|
emf |
152 |
|
(invoke-emf emf args)))))))) |
153 |
|
#'(lambda (cache emf miss-fn) |
154 |
|
(declare (type function miss-fn)) |
155 |
|
(fin-lambda-fn (&rest args) |
156 |
|
(declare #.*optimize-speed*) |
157 |
|
#+copy-&rest-arg (setq args (copy-list args)) |
158 |
|
(with-dfun-wrappers (args metatypes) (dfun-wrappers invalid-wrapper-p) |
159 |
|
(apply miss-fn args) |
160 |
|
(if invalid-wrapper-p |
161 |
|
(apply miss-fn args) |
162 |
|
(let ((found-p (not (eq not-in-cache |
163 |
|
(probe-cache cache dfun-wrappers |
164 |
|
not-in-cache))))) |
165 |
|
(if found-p |
166 |
|
(invoke-emf emf args) |
167 |
|
(if return-value-p |
168 |
|
t |
169 |
|
(apply miss-fn args)))))))))) |
170 |
|
|
171 |
|
|
172 |
|
(defun emit-default-only-function (metatypes applyp) |
173 |
|
(declare (ignore metatypes applyp)) |
174 |
|
(values #'(lambda (emf) |
175 |
|
#'(lambda (&rest args) |
176 |
|
#+copy-&rest-arg (setq args (copy-list args)) |
177 |
|
(invoke-emf emf args))) |
178 |
|
t)) |