/[gcl]/gcl/pcl/gcl_pcl_slots_boot.lisp
ViewVC logotype

Diff of /gcl/pcl/gcl_pcl_slots_boot.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.1 by camm, Fri May 6 21:56:56 2005 UTC revision 1.2 by camm, Sat May 7 02:52:30 2005 UTC
# Line 0  Line 1 
1    ;;;-*-Mode:LISP; Package:PCL; 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    (defmacro slot-symbol (slot-name type)
31      `(if (symbolp ,slot-name)
32           (or (get ,slot-name ',(ecase type
33                                   (reader 'reader-symbol)
34                                   (writer 'writer-symbol)
35                                   (boundp 'boundp-symbol)))
36               (intern (format nil "~A ~A slot ~a"
37                               (if (symbol-package ,slot-name)
38                                   (package-name (symbol-package ,slot-name))
39                                 "UNINTERNED")
40                               (symbol-name ,slot-name)
41                               ,(symbol-name type))
42                       *slot-accessor-name-package*))
43           (progn
44             (error "non-symbol and non-interned symbol slot name accessors~
45                     are not yet implemented")
46             ;;(make-symbol (format nil "~a ~a" ,slot-name ,type))
47             )))
48    
49    (defun slot-reader-symbol (slot-name)
50      (slot-symbol slot-name reader))
51    
52    (defun slot-writer-symbol (slot-name)
53      (slot-symbol slot-name writer))
54    
55    (defun slot-boundp-symbol (slot-name)
56      (slot-symbol slot-name boundp))
57    
58    (defmacro asv-funcall (sym slot-name type &rest args)
59      (declare (ignore type))
60      `(if (#-akcl fboundp #+akcl %fboundp ',sym)
61           (,sym ,@args)
62           (no-slot ',sym ',slot-name)))
63    
64    (defun no-slot (sym slot-name)
65      (error "No class has a slot named ~S (~s has no function binding)."
66             slot-name sym))
67    
68    (defmacro accessor-slot-value (object slot-name)
69      (unless (constantp slot-name)
70        (error "~s requires its slot-name argument to be a constant"
71               'accessor-slot-value))
72      (let* ((slot-name (eval slot-name))
73             (sym (slot-reader-symbol slot-name)))
74        `(asv-funcall ,sym ,slot-name reader ,object)))
75    
76    (defmacro accessor-set-slot-value (object slot-name new-value &environment env)
77      (unless (constantp slot-name)
78        (error "~s requires its slot-name argument to be a constant"
79               'accessor-set-slot-value))
80      (setq object (macroexpand object env))
81      (setq slot-name (macroexpand slot-name env))
82      (let* ((slot-name (eval slot-name))
83             (bindings (unless (or (constantp new-value) (atom new-value))
84                         (let ((object-var (gensym)))
85                           (prog1 `((,object-var ,object))
86                             (setq object object-var)))))
87             (sym (slot-writer-symbol slot-name))
88             (form `(asv-funcall ,sym ,slot-name writer ,new-value ,object)))
89        (if bindings
90            `(let ,bindings ,form)
91            form)))
92    
93    (defconstant *optimize-slot-boundp* nil)
94    
95    (defmacro accessor-slot-boundp (object slot-name)
96      (unless (constantp slot-name)
97        (error "~s requires its slot-name argument to be a constant"
98               'accessor-slot-boundp))
99      (let* ((slot-name (eval slot-name))
100             (sym (slot-boundp-symbol slot-name)))
101        (if (not *optimize-slot-boundp*)
102            `(slot-boundp-normal ,object ',slot-name)
103            `(asv-funcall ,sym ,slot-name boundp ,object))))
104    
105    
106    (defun structure-slot-boundp (object)
107      (declare (ignore object))
108      t)
109    
110    (defun make-structure-slot-boundp-function (slotd)
111      (let* ((reader (slot-definition-internal-reader-function slotd))
112             (fun #'(lambda (object)
113                      (not (eq (funcall reader object) *slot-unbound*)))))
114        (declare (type function reader))
115        #+(and kcl turbo-closure) (si:turbo-closure fun)
116        fun))                  
117    
118    (defun get-optimized-std-accessor-method-function (class slotd name)
119      (if (structure-class-p class)
120          (ecase name
121            (reader (slot-definition-internal-reader-function slotd))
122            (writer (slot-definition-internal-writer-function slotd))
123            (boundp (make-structure-slot-boundp-function slotd)))
124          (let* ((fsc-p (cond ((standard-class-p class) nil)
125                              ((funcallable-standard-class-p class) t)
126                              (t (error "~S is not a standard-class" class))))
127                 (slot-name (slot-definition-name slotd))
128                 (index (slot-definition-location slotd))
129                 (function (ecase name
130                             (reader #'make-optimized-std-reader-method-function)
131                             (writer #'make-optimized-std-writer-method-function)
132                             (boundp #'make-optimized-std-boundp-method-function)))
133                 (value (funcall function fsc-p slot-name index)))
134            (declare (type function function))
135            (values value index))))
136    
137    (defun make-optimized-std-reader-method-function (fsc-p slot-name index)
138      (declare #.*optimize-speed*)
139      (set-function-name
140       (etypecase index
141         (fixnum (if fsc-p
142                     #'(lambda (instance)
143                         (let ((value (%instance-ref (fsc-instance-slots instance) index)))
144                           (if (eq value *slot-unbound*)
145                               (slot-unbound (class-of instance) instance slot-name)
146                               value)))
147                     #'(lambda (instance)
148                         (let ((value (%instance-ref (std-instance-slots instance) index)))
149                           (if (eq value *slot-unbound*)
150                               (slot-unbound (class-of instance) instance slot-name)
151                               value)))))
152         (cons   #'(lambda (instance)
153                     (let ((value (cdr index)))
154                       (if (eq value *slot-unbound*)
155                           (slot-unbound (class-of instance) instance slot-name)
156                           value)))))
157       `(reader ,slot-name)))
158    
159    (defun make-optimized-std-writer-method-function (fsc-p slot-name index)
160      (declare #.*optimize-speed*)
161      (set-function-name
162       (etypecase index
163         (fixnum (if fsc-p
164                     #'(lambda (nv instance)
165                         (setf (%instance-ref (fsc-instance-slots instance) index) nv))
166                     #'(lambda (nv instance)
167                         (setf (%instance-ref (std-instance-slots instance) index) nv))))
168         (cons   #'(lambda (nv instance)
169                     (declare (ignore instance))
170                     (setf (cdr index) nv))))
171       `(writer ,slot-name)))
172    
173    (defun make-optimized-std-boundp-method-function (fsc-p slot-name index)
174      (declare #.*optimize-speed*)
175      (set-function-name
176       (etypecase index
177         (fixnum (if fsc-p
178                     #'(lambda (instance)
179                         (not (eq *slot-unbound*
180                                  (%instance-ref (fsc-instance-slots instance) index))))
181                     #'(lambda (instance)
182                         (not (eq *slot-unbound*
183                                  (%instance-ref (std-instance-slots instance) index))))))
184         (cons   #'(lambda (instance)
185                     (declare (ignore instance))
186                     (not (eq *slot-unbound* (cdr index))))))
187       `(boundp ,slot-name)))
188    
189    (defun make-optimized-structure-slot-value-using-class-method-function (function)
190      #+cmu (declare (type function function))
191      #'(lambda (class object slotd)
192          (let ((value (funcall function object)))
193            (if (eq value *slot-unbound*)
194                (slot-unbound class object (slot-definition-name slotd))
195                value))))      
196    
197    (defun make-optimized-structure-setf-slot-value-using-class-method-function (function)
198      #+cmu (declare (type function function))
199      #'(lambda (nv class object slotd)
200          (declare (ignore class slotd))
201          (funcall function nv object)))
202    
203    (defun make-optimized-structure-slot-boundp-using-class-method-function (function)
204      #+cmu (declare (type function function))
205      #'(lambda (class object slotd)
206          (declare (ignore class slotd))
207          (not (eq (funcall function object) *slot-unbound*))))
208    
209    (defun get-optimized-std-slot-value-using-class-method-function (class slotd name)
210      (if (structure-class-p class)
211          (ecase name
212            (reader (make-optimized-structure-slot-value-using-class-method-function
213                     (slot-definition-internal-reader-function slotd)))
214            (writer (make-optimized-structure-setf-slot-value-using-class-method-function
215                     (slot-definition-internal-writer-function slotd)))
216            (boundp (make-optimized-structure-slot-boundp-using-class-method-function
217                     (slot-definition-internal-writer-function slotd))))
218          (let* ((fsc-p (cond ((standard-class-p class) nil)
219                              ((funcallable-standard-class-p class) t)
220                              (t (error "~S is not a standard-class" class))))
221                 (slot-name (slot-definition-name slotd))
222                 (index (slot-definition-location slotd))
223                 (function
224                  (ecase name
225                    (reader
226                     #'make-optimized-std-slot-value-using-class-method-function)
227                    (writer
228                     #'make-optimized-std-setf-slot-value-using-class-method-function)
229                    (boundp
230                     #'make-optimized-std-slot-boundp-using-class-method-function))))
231            #+cmu (declare (type function function))
232            (values (funcall function fsc-p slot-name index) index))))
233    
234    (defun make-optimized-std-slot-value-using-class-method-function
235        (fsc-p slot-name index)
236      (declare #.*optimize-speed*)
237      (etypecase index
238        (fixnum (if fsc-p
239                    #'(lambda (class instance slotd)
240                        (declare (ignore slotd))
241                        (unless (fsc-instance-p instance) (error "not fsc"))
242                        (let ((value (%instance-ref (fsc-instance-slots instance) index)))
243                          (if (eq value *slot-unbound*)
244                              (slot-unbound class instance slot-name)
245                              value)))
246                    #'(lambda (class instance slotd)
247                        (declare (ignore slotd))
248                        (unless (std-instance-p instance) (error "not std"))
249                        (let ((value (%instance-ref (std-instance-slots instance) index)))
250                          (if (eq value *slot-unbound*)
251                              (slot-unbound class instance slot-name)
252                              value)))))
253        (cons   #'(lambda (class instance slotd)
254                    (declare (ignore slotd))
255                    (let ((value (cdr index)))
256                      (if (eq value *slot-unbound*)
257                          (slot-unbound class instance slot-name)
258                          value))))))
259    
260    (defun make-optimized-std-setf-slot-value-using-class-method-function
261        (fsc-p slot-name index)
262      (declare #.*optimize-speed*)
263      (declare (ignore slot-name))
264      (etypecase index
265        (fixnum (if fsc-p
266                    #'(lambda (nv class instance slotd)
267                        (declare (ignore class slotd))
268                        (setf (%instance-ref (fsc-instance-slots instance) index) nv))
269                    #'(lambda (nv class instance slotd)
270                        (declare (ignore class slotd))
271                        (setf (%instance-ref (std-instance-slots instance) index) nv))))
272        (cons   #'(lambda (nv class instance slotd)
273                    (declare (ignore class instance slotd))
274                    (setf (cdr index) nv)))))
275    
276    (defun make-optimized-std-slot-boundp-using-class-method-function
277        (fsc-p slot-name index)
278      (declare #.*optimize-speed*)
279      (declare (ignore slot-name))
280      (etypecase index
281        (fixnum (if fsc-p
282                    #'(lambda (class instance slotd)
283                        (declare (ignore class slotd))
284                        (not (eq *slot-unbound*
285                                 (%instance-ref (fsc-instance-slots instance) index))))
286                    #'(lambda (class instance slotd)
287                        (declare (ignore class slotd))
288                        (not (eq *slot-unbound*
289                                 (%instance-ref (std-instance-slots instance) index))))))
290        (cons   #'(lambda (class instance slotd)
291                    (declare (ignore class instance slotd))
292                    (not (eq *slot-unbound* (cdr index)))))))
293    
294    (defun get-accessor-from-svuc-method-function (class slotd sdfun name)
295      (macrolet ((emf-funcall (emf &rest args)
296                   `(invoke-effective-method-function ,emf nil ,@args)))
297        (set-function-name
298         (case name
299           (reader #'(lambda (instance) (emf-funcall sdfun class instance slotd)))
300           (writer #'(lambda (nv instance) (emf-funcall sdfun nv class instance slotd)))
301           (boundp #'(lambda (instance) (emf-funcall sdfun class instance slotd))))
302         `(,name ,(class-name class) ,(slot-definition-name slotd)))))
303    
304    (defun make-internal-reader-method-function (class-name slot-name)
305      (list* ':method-spec `(internal-reader-method ,class-name ,slot-name)
306             (make-method-function
307              (lambda (instance)
308                (let ((wrapper (get-instance-wrapper-or-nil instance)))
309                  (if wrapper
310                      (let* ((class (wrapper-class* wrapper))
311                             (index (or (instance-slot-index wrapper slot-name)
312                                        (assq slot-name (wrapper-class-slots wrapper)))))
313                        (typecase index
314                          (fixnum  
315                           (let ((value (%instance-ref (get-slots instance) index)))
316                             (if (eq value *slot-unbound*)
317                                 (slot-unbound (class-of instance) instance slot-name)
318                                 value)))
319                          (cons
320                           (let ((value (cdr index)))
321                             (if (eq value *slot-unbound*)
322                                 (slot-unbound (class-of instance) instance slot-name)
323                                 value)))
324                          (t
325                           (error "The wrapper for class ~S does not have the slot ~S"
326                                  class slot-name))))
327                      (slot-value instance slot-name)))))))
328    
329    
330    (defun make-std-reader-method-function (class-name slot-name)
331      (let* ((pv-table-symbol (gensym))
332             (initargs (copy-tree
333                        (make-method-function
334                         (lambda (instance)
335                           (pv-binding1 (.pv. .calls.
336                                              (symbol-value pv-table-symbol)
337                                              (instance) (instance-slots))
338                             (instance-read-internal
339                              .pv. instance-slots 1
340                              (slot-value instance slot-name))))))))
341        (setf (getf (getf initargs ':plist) ':slot-name-lists)
342              (list (list nil slot-name)))
343        (setf (getf (getf initargs ':plist) ':pv-table-symbol) pv-table-symbol)
344        (list* ':method-spec `(reader-method ,class-name ,slot-name)
345               initargs)))
346    
347    (defun make-std-writer-method-function (class-name slot-name)
348      (let* ((pv-table-symbol (gensym))
349             (initargs (copy-tree
350                        (make-method-function
351                         (lambda (nv instance)
352                           (pv-binding1 (.pv. .calls.
353                                              (symbol-value pv-table-symbol)
354                                              (instance) (instance-slots))
355                             (instance-write-internal
356                              .pv. instance-slots 1 nv
357                              (setf (slot-value instance slot-name) nv))))))))
358        (setf (getf (getf initargs ':plist) ':slot-name-lists)
359              (list nil (list nil slot-name)))
360        (setf (getf (getf initargs ':plist) ':pv-table-symbol) pv-table-symbol)
361        (list* ':method-spec `(writer-method ,class-name ,slot-name)
362               initargs)))
363    
364    (defun make-std-boundp-method-function (class-name slot-name)
365      (let* ((pv-table-symbol (gensym))
366             (initargs (copy-tree
367                        (make-method-function
368                         (lambda (instance)
369                           (pv-binding1 (.pv. .calls.
370                                              (symbol-value pv-table-symbol)
371                                              (instance) (instance-slots))
372                              (instance-boundp-internal
373                               .pv. instance-slots 1
374                               (slot-boundp instance slot-name))))))))
375        (setf (getf (getf initargs ':plist) ':slot-name-lists)
376              (list (list nil slot-name)))
377        (setf (getf (getf initargs ':plist) ':pv-table-symbol) pv-table-symbol)
378        (list* ':method-spec `(boundp-method ,class-name ,slot-name)
379               initargs)))
380    
381    (defun initialize-internal-slot-gfs (slot-name &optional type)
382      (when (or (null type) (eq type 'reader))
383        (let* ((name (slot-reader-symbol slot-name))
384               (gf (ensure-generic-function name)))
385          (unless (generic-function-methods gf)
386            (add-reader-method *the-class-slot-object* gf slot-name))))
387      (when (or (null type) (eq type 'writer))
388        (let* ((name (slot-writer-symbol slot-name))
389               (gf (ensure-generic-function name)))
390          (unless (generic-function-methods gf)
391            (add-writer-method *the-class-slot-object* gf slot-name))))
392      (when (and *optimize-slot-boundp*
393                 (or (null type) (eq type 'boundp)))
394        (let* ((name (slot-boundp-symbol slot-name))
395               (gf (ensure-generic-function name)))
396          (unless (generic-function-methods gf)
397            (add-boundp-method *the-class-slot-object* gf slot-name))))
398      nil)
399    
400    (defun initialize-internal-slot-gfs* (readers writers boundps)
401      (dolist (reader readers)
402        (initialize-internal-slot-gfs reader 'reader))
403      (dolist (writer writers)
404        (initialize-internal-slot-gfs writer 'writer))
405      (dolist (boundp boundps)
406        (initialize-internal-slot-gfs boundp 'boundp)))

Legend:
Removed from v.1.1  
changed lines
  Added in v.1.2

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26