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

Diff of /gcl/pcl/gcl_pcl_braid.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 (LISP WALKER)); 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    ;;; Bootstrapping the meta-braid.
28    ;;;
29    ;;; The code in this file takes the early definitions that have been saved
30    ;;; up and actually builds those class objects.  This work is largely driven
31    ;;; off of those class definitions, but the fact that STANDARD-CLASS is the
32    ;;; class of all metaclasses in the braid is built into this code pretty
33    ;;; deeply.
34    ;;;
35    ;;;
36    
37    (in-package :pcl)
38    
39    (defun allocate-standard-instance (wrapper &optional (slots-init nil slots-init-p))
40      #-new-kcl-wrapper (declare (special *slot-unbound*))
41      #-new-kcl-wrapper
42      (let ((instance (%%allocate-instance--class)))
43        (setf (std-instance-wrapper instance) wrapper)
44        (setf (std-instance-slots instance)
45              (if slots-init-p
46                  (copy-slots slots-init)
47                  (make-array (wrapper-no-of-instance-slots wrapper)
48                              :initial-element *slot-unbound*)))
49        instance)
50      #+new-kcl-wrapper
51      (apply #'si:make-structure wrapper
52             (if slots-init-p
53                 slots-init
54                 (let ((no-of-slots (si::s-data-length wrapper)))
55                   (if (< no-of-slots (fill-pointer *init-vector*))
56                       (aref *init-vector* no-of-slots)
57                       (get-init-list no-of-slots))))))
58    
59    (defmacro allocate-funcallable-instance-slots (wrapper &optional
60                                                           slots-init-p slots-init)
61      #-new-kcl-wrapper
62      `(let ((no-of-slots (wrapper-no-of-instance-slots ,wrapper)))
63         ,(if slots-init-p
64              `(if ,slots-init-p
65                   (copy-slots ,slots-init)
66                   (make-array no-of-slots :initial-element *slot-unbound*))
67              `(make-array no-of-slots :initial-element *slot-unbound*)))
68      #+new-kcl-wrapper
69      (if slots-init-p
70          `(if ,slots-init-p
71               (allocate-standard-instance ,wrapper ,slots-init)
72               (allocate-standard-instance ,wrapper))
73          `(allocate-standard-instance ,wrapper)))
74    
75    (defun allocate-funcallable-instance (wrapper &optional (slots-init nil slots-init-p))
76      (let ((fin (allocate-funcallable-instance-1)))
77        (set-funcallable-instance-function
78         fin
79         (fin-lambda-fn (&rest args)
80           (declare (ignore args))
81           (error "The function of the funcallable-instance ~S has not been set" fin)))
82        (setf (fsc-instance-wrapper fin) wrapper
83              (fsc-instance-slots fin) (allocate-funcallable-instance-slots
84                                        wrapper slots-init-p slots-init))
85        fin))
86    
87    (defun allocate-structure-instance (wrapper &optional (slots-init nil slots-init-p))
88      #-new-kcl-wrapper
89      (let* ((class (wrapper-class wrapper))
90             (constructor (class-defstruct-constructor class)))
91        (if constructor
92            (let ((instance (funcall constructor))
93                  (slots (class-slots class)))
94              (when slots-init-p
95                (dotimes (i (length slots-init))
96                  (let ((slot (pop slots)))
97                    (setf (slot-value-using-class class instance slot)
98                          (svref slots-init i)))))
99              instance)
100            (error "Can't allocate an instance of class ~S" (class-name class))))
101      #+new-kcl-wrapper
102      (if slots-init-p
103          (allocate-standard-instance wrapper slots-init)
104          (allocate-standard-instance wrapper)))
105    
106    ;;;
107    ;;; bootstrap-meta-braid
108    ;;;
109    ;;; This function builds the base metabraid from the early class definitions.
110    ;;;  
111    (defmacro initial-classes-and-wrappers (&rest classes)
112      `(progn
113         ,@(mapcar #'(lambda (class)
114                       (let ((wr (intern (format nil "~A-WRAPPER" class)
115                                         *the-pcl-package*)))
116                         `(setf ,wr ,(if (eq class 'standard-generic-function)
117                                         '*sgf-wrapper*
118                                         #-cmu17
119                                         `(make-wrapper (early-class-size ',class))
120                                         #+cmu17
121                                         `(boot-make-wrapper
122                                           (early-class-size ',class)
123                                           ',class))
124                                ,class (allocate-standard-instance
125                                        ,(if (eq class 'standard-generic-function)
126                                             'funcallable-standard-class-wrapper
127                                             'standard-class-wrapper))
128                                (wrapper-class ,wr) ,class
129                                #+new-kcl-wrapper (si::s-data-name ,wr)
130                                       #+new-kcl-wrapper ',class
131                                (find-class ',class) ,class)))
132                  classes)))                        
133    
134    (defun bootstrap-meta-braid ()
135      (let* ((name 'class)
136             (predicate-name (make-type-predicate-name name)))
137        (setf (gdefinition predicate-name)
138              #'(lambda (x) (declare (ignore x)) t))
139        (do-satisfies-deftype name predicate-name))  
140      (let* ((*create-classes-from-internal-structure-definitions-p* nil)
141             standard-class-wrapper standard-class
142             funcallable-standard-class-wrapper funcallable-standard-class
143             slot-class-wrapper slot-class
144             built-in-class-wrapper built-in-class
145             structure-class-wrapper structure-class
146             standard-direct-slot-definition-wrapper standard-direct-slot-definition
147             standard-effective-slot-definition-wrapper standard-effective-slot-definition
148             class-eq-specializer-wrapper class-eq-specializer
149             standard-generic-function-wrapper standard-generic-function)
150        (initial-classes-and-wrappers
151         standard-class funcallable-standard-class
152         slot-class built-in-class structure-class
153         standard-direct-slot-definition standard-effective-slot-definition
154         class-eq-specializer standard-generic-function)
155        ;;
156        ;; First, make a class metaobject for each of the early classes.  For
157        ;; each metaobject we also set its wrapper.  Except for the class T,
158        ;; the wrapper is always that of STANDARD-CLASS.
159        ;;
160        (dolist (definition *early-class-definitions*)
161          (let* ((name (ecd-class-name definition))
162                 (meta (ecd-metaclass definition))
163                 (wrapper (ecase meta
164                            (slot-class slot-class-wrapper)
165                            (standard-class standard-class-wrapper)
166                            (funcallable-standard-class funcallable-standard-class-wrapper)
167                            (built-in-class built-in-class-wrapper)
168                            (structure-class structure-class-wrapper)))
169                 (class (or (find-class name nil)
170                            (allocate-standard-instance wrapper))))
171            (when (or (eq meta 'standard-class) (eq meta 'funcallable-standard-class))
172              (inform-type-system-about-std-class name))
173            (setf (find-class name) class)))
174        ;;
175        ;;
176        ;;
177        (dolist (definition *early-class-definitions*)
178          (let ((name (ecd-class-name definition))
179                (meta (ecd-metaclass definition))
180                (source (ecd-source definition))
181                (direct-supers (ecd-superclass-names definition))
182                (direct-slots  (ecd-canonical-slots definition))
183                (other-initargs (ecd-other-initargs definition)))
184            (let ((direct-default-initargs
185                   (getf other-initargs :direct-default-initargs)))
186              (multiple-value-bind (slots cpl default-initargs direct-subclasses)
187                  (early-collect-inheritance name)
188                (let* ((class (find-class name))
189                       (wrapper (cond ((eq class slot-class)
190                                       slot-class-wrapper)
191                                      ((eq class standard-class)
192                                       standard-class-wrapper)
193                                      ((eq class funcallable-standard-class)
194                                       funcallable-standard-class-wrapper)
195                                      ((eq class standard-direct-slot-definition)
196                                       standard-direct-slot-definition-wrapper)
197                                      ((eq class standard-effective-slot-definition)
198                                       standard-effective-slot-definition-wrapper)
199                                      ((eq class built-in-class)  
200                                       built-in-class-wrapper)
201                                      ((eq class structure-class)
202                                       structure-class-wrapper)
203                                      ((eq class class-eq-specializer)
204                                       class-eq-specializer-wrapper)
205                                      ((eq class standard-generic-function)
206                                       standard-generic-function-wrapper)
207                                      (t
208                                       #-cmu17
209                                       (make-wrapper (length slots) class)
210                                       #+cmu17
211                                       (boot-make-wrapper (length slots) name))))
212                       (proto nil))
213                  (when (eq name 't) (setq *the-wrapper-of-t* wrapper))
214                  (set (intern (format nil "*THE-CLASS-~A*" (symbol-name name))
215                               *the-pcl-package*)
216                       class)
217                  (dolist (slot slots)
218                    (unless (eq (getf slot :allocation :instance) :instance)
219                      (error "Slot allocation ~S not supported in bootstrap.")))
220                  
221                  (when #+cmu17 (typep wrapper 'wrapper) #-cmu17 t
222                    (setf (wrapper-instance-slots-layout wrapper)
223                          (mapcar #'canonical-slot-name slots))
224                    (setf (wrapper-class-slots wrapper)
225                          ()))
226                  
227                  (setq proto (if (eq meta 'funcallable-standard-class)
228                                  (allocate-funcallable-instance wrapper)
229                                  (allocate-standard-instance wrapper)))
230                
231                  (setq direct-slots
232                        (bootstrap-make-slot-definitions
233                         name class direct-slots
234                         standard-direct-slot-definition-wrapper nil))
235                  (setq slots
236                        (bootstrap-make-slot-definitions
237                         name class slots
238                         standard-effective-slot-definition-wrapper t))
239                  
240                  (case meta
241                    ((standard-class funcallable-standard-class)
242                     (bootstrap-initialize-class
243                      meta
244                      class name class-eq-specializer-wrapper source
245                      direct-supers direct-subclasses cpl wrapper proto
246                      direct-slots slots direct-default-initargs default-initargs))
247                    (built-in-class         ; *the-class-t*
248                     (bootstrap-initialize-class
249                      meta
250                      class name class-eq-specializer-wrapper source
251                      direct-supers direct-subclasses cpl wrapper proto))
252                    (slot-class             ; *the-class-slot-object*
253                     (bootstrap-initialize-class
254                      meta
255                      class name class-eq-specializer-wrapper source
256                      direct-supers direct-subclasses cpl wrapper proto))
257                    (structure-class        ; *the-class-structure-object*
258                     (bootstrap-initialize-class
259                      meta
260                      class name class-eq-specializer-wrapper source
261                      direct-supers direct-subclasses cpl wrapper))))))))
262    
263        (let* ((smc-class (find-class 'standard-method-combination))
264               (smc-wrapper (bootstrap-get-slot 'standard-class smc-class 'wrapper))
265               (smc (allocate-standard-instance smc-wrapper)))
266          (flet ((set-slot (name value)
267                   (bootstrap-set-slot 'standard-method-combination smc name value)))
268            (set-slot 'source (load-truename))
269            (set-slot 'type 'standard)
270            (set-slot 'documentation "The standard method combination.")
271            (set-slot 'options ()))
272          (setq *standard-method-combination* smc))))
273    
274    ;;;
275    ;;; Initialize a class metaobject.
276    ;;;
277    (defun bootstrap-initialize-class
278           (metaclass-name class name
279            class-eq-wrapper source direct-supers direct-subclasses cpl wrapper
280            &optional proto direct-slots slots direct-default-initargs default-initargs)
281      (flet ((classes (names) (mapcar #'find-class names))
282             (set-slot (slot-name value)
283               (bootstrap-set-slot metaclass-name class slot-name value)))
284        (set-slot 'name name)
285        (set-slot 'source source)
286        (set-slot 'type (if (eq class (find-class 't))
287                            t
288                            `(class ,class)))
289        (set-slot 'class-eq-specializer
290                  (let ((spec (allocate-standard-instance class-eq-wrapper)))
291                    (bootstrap-set-slot 'class-eq-specializer spec 'type
292                                        `(class-eq ,class))
293                    (bootstrap-set-slot 'class-eq-specializer spec 'object
294                                        class)
295                    spec))
296        (set-slot 'class-precedence-list (classes cpl))
297        (set-slot 'can-precede-list (classes (cdr cpl)))
298        (set-slot 'incompatible-superclass-list nil)
299        (set-slot 'direct-superclasses (classes direct-supers))
300        (set-slot 'direct-subclasses (classes direct-subclasses))
301        (set-slot 'direct-methods (cons nil nil))
302        (set-slot 'wrapper wrapper)
303        #+new-kcl-wrapper
304        (setf (si::s-data-name wrapper) name)
305        (set-slot 'predicate-name (or (cadr (assoc name *early-class-predicates*))
306                                      (make-class-predicate-name name)))
307        (set-slot 'plist
308                  `(,@(and direct-default-initargs
309                           `(direct-default-initargs ,direct-default-initargs))
310                    ,@(and default-initargs
311                           `(default-initargs ,default-initargs))))
312        (when (memq metaclass-name '(standard-class funcallable-standard-class
313                                     structure-class slot-class))
314          (set-slot 'direct-slots direct-slots)
315          (set-slot 'slots slots)
316          (set-slot 'initialize-info nil))
317        (if (eq metaclass-name 'structure-class)
318            (let ((constructor-sym '|STRUCTURE-OBJECT class constructor|))
319              (set-slot 'predicate-name (or (cadr (assoc name *early-class-predicates*))
320                                            (make-class-predicate-name name)))
321              (set-slot 'defstruct-form
322                        `(defstruct (structure-object (:constructor ,constructor-sym))))
323              (set-slot 'defstruct-constructor constructor-sym)
324              (set-slot 'from-defclass-p t)    
325              (set-slot 'plist nil)
326              (set-slot 'prototype (funcall constructor-sym)))
327            (set-slot 'prototype (or proto (allocate-standard-instance wrapper))))
328        class))
329    
330    (defun bootstrap-make-slot-definitions (name class slots wrapper effective-p)
331      (let ((index -1))
332        (mapcar #'(lambda (slot)
333                    (incf index)
334                    (bootstrap-make-slot-definition
335                      name class slot wrapper effective-p index))
336                slots)))
337    
338    (defun bootstrap-make-slot-definition (name class slot wrapper effective-p index)  
339      (let* ((slotd-class-name (if effective-p
340                                   'standard-effective-slot-definition
341                                   'standard-direct-slot-definition))
342             (slotd (allocate-standard-instance wrapper))
343             (slot-name (getf slot :name)))
344        (flet ((get-val (name) (getf slot name))
345               (set-val (name val) (bootstrap-set-slot slotd-class-name slotd name val)))
346          (set-val 'name         slot-name)
347          (set-val 'initform     (get-val :initform))
348          (set-val 'initfunction (get-val :initfunction))      
349          (set-val 'initargs     (get-val :initargs))
350          (set-val 'readers      (get-val :readers))
351          (set-val 'writers      (get-val :writers))
352          (set-val 'allocation   :instance)
353          (set-val 'type         (or (get-val :type) t))
354          (set-val 'documentation (or (get-val :documentation) ""))
355          (set-val 'class        class)
356          (when effective-p
357            (set-val 'location index)
358            (let ((fsc-p nil))
359              (set-val 'reader-function (make-optimized-std-reader-method-function
360                                         fsc-p slot-name index))
361              (set-val 'writer-function (make-optimized-std-writer-method-function
362                                         fsc-p slot-name index))
363              (set-val 'boundp-function (make-optimized-std-boundp-method-function
364                                         fsc-p slot-name index)))
365            (set-val 'accessor-flags 7)
366            (let ((table (or (gethash slot-name *name->class->slotd-table*)
367                             (setf (gethash slot-name *name->class->slotd-table*)
368                                   (make-hash-table :test 'eq :size 5)))))
369              (setf (gethash class table) slotd)))
370          (when (and (eq name 'standard-class)
371                     (eq slot-name 'slots) effective-p)
372            (setq *the-eslotd-standard-class-slots* slotd))
373          (when (and (eq name 'funcallable-standard-class)
374                     (eq slot-name 'slots) effective-p)
375            (setq *the-eslotd-funcallable-standard-class-slots* slotd))
376          slotd)))
377    
378    (defun bootstrap-accessor-definitions (early-p)
379      (let ((*early-p* early-p))
380        (dolist (definition *early-class-definitions*)
381          (let ((name (ecd-class-name definition))
382                (meta (ecd-metaclass definition)))
383            (unless (eq meta 'built-in-class)
384              (let ((direct-slots  (ecd-canonical-slots definition)))
385                (dolist (slotd direct-slots)
386                  (let ((slot-name (getf slotd :name))
387                        (readers (getf slotd :readers))
388                        (writers (getf slotd :writers)))
389                    (bootstrap-accessor-definitions1 name slot-name readers writers nil)
390                    (bootstrap-accessor-definitions1
391                     'slot-object
392                     slot-name
393                     (list (slot-reader-symbol slot-name))
394                     (list (slot-writer-symbol slot-name))
395                     (list (slot-boundp-symbol slot-name)))))))))))
396    
397    (defun bootstrap-accessor-definition (class-name accessor-name slot-name type)
398      (multiple-value-bind (accessor-class make-method-function arglist specls doc)
399          (ecase type
400            (reader (values 'standard-reader-method #'make-std-reader-method-function
401                            (list class-name) (list class-name)
402                            "automatically generated reader method"))
403            (writer (values 'standard-writer-method #'make-std-writer-method-function
404                            (list 'new-value class-name) (list 't class-name)
405                            "automatically generated writer method"))
406            (boundp (values 'standard-boundp-method #'make-std-boundp-method-function
407                            (list class-name) (list class-name)
408                            "automatically generated boundp method")))
409        (let ((gf (ensure-generic-function accessor-name)))
410          (if (find specls (early-gf-methods gf)
411                    :key #'early-method-specializers
412                    :test #'equal)
413              (unless (assoc accessor-name *generic-function-fixups*
414                             :test #'equal)
415                (update-dfun gf))
416              (add-method gf
417                          (make-a-method accessor-class
418                                         ()
419                                         arglist specls
420                                         (funcall make-method-function
421                                                  class-name slot-name)
422                                         doc
423                                         slot-name))))))
424    
425    (defun bootstrap-accessor-definitions1 (class-name slot-name readers writers boundps)
426      (flet ((do-reader-definition (reader)
427               (bootstrap-accessor-definition class-name reader slot-name 'reader))
428             (do-writer-definition (writer)
429               (bootstrap-accessor-definition class-name writer slot-name 'writer))
430             (do-boundp-definition (boundp)
431               (bootstrap-accessor-definition class-name boundp slot-name 'boundp)))
432        (dolist (reader readers) (do-reader-definition reader))
433        (dolist (writer writers) (do-writer-definition writer))
434        (dolist (boundp boundps) (do-boundp-definition boundp))))
435    
436    (defun bootstrap-class-predicates (early-p)
437      (let ((*early-p* early-p))
438        (dolist (definition *early-class-definitions*)
439          (let* ((name (ecd-class-name definition))
440                 (class (find-class name)))
441            (setf (find-class-predicate name)
442                  (make-class-predicate class (class-predicate-name class)))))))
443    
444    (defun bootstrap-built-in-classes ()
445      ;;
446      ;; First make sure that all the supers listed in *built-in-class-lattice*
447      ;; are themselves defined by *built-in-class-lattice*.  This is just to
448      ;; check for typos and other sorts of brainos.
449      ;;
450      (dolist (e *built-in-classes*)
451        (dolist (super (cadr e))
452          (unless (or (eq super 't)
453                      (assq super *built-in-classes*))
454            (error "In *built-in-classes*: ~S has ~S as a super,~%~
455                    but ~S is not itself a class in *built-in-classes*."
456                   (car e) super super))))
457    
458      ;;
459      ;; In the first pass, we create a skeletal object to be bound to the
460      ;; class name.
461      ;;
462      (let* ((built-in-class (find-class 'built-in-class))
463             (built-in-class-wrapper (class-wrapper built-in-class)))
464        (dolist (e *built-in-classes*)
465          (let ((class (allocate-standard-instance built-in-class-wrapper)))
466            (setf (find-class (car e)) class))))
467    
468      ;;
469      ;; In the second pass, we initialize the class objects.
470      ;;
471      (let ((class-eq-wrapper (class-wrapper (find-class 'class-eq-specializer))))
472        (dolist (e *built-in-classes*)
473        ; FIXME use regular destructuring-bind
474          (pcl-destructuring-bind (name supers subs cpl prototype) e
475            (let* ((class (find-class name))
476                   #+cmu17
477                   (lclass (lisp:find-class name))
478                   (wrapper #-cmu17(make-wrapper 0 class)
479                            #+cmu17(kernel:class-layout lclass)))
480              (set (get-built-in-class-symbol name) class)
481              (set (get-built-in-wrapper-symbol name) wrapper)
482              #+cmu17
483              (setf (kernel:class-pcl-class lclass) class)
484              #-cmu17
485              (setf (wrapper-instance-slots-layout wrapper) ()
486                    (wrapper-class-slots wrapper) ())
487    
488              (bootstrap-initialize-class 'built-in-class class
489                                          name class-eq-wrapper nil
490                                          supers subs
491                                          (cons name cpl)
492                                          wrapper prototype)))))
493      
494      (dolist (e *built-in-classes*)
495        (let* ((name (car e))
496               (class (find-class name)))
497          (setf (find-class-predicate name)
498                (make-class-predicate class (class-predicate-name class))))))
499    
500    
501    ;;;
502    ;;;
503    ;;;
504    #-(or new-kcl-wrapper cmu17)
505    (progn
506    (defvar *built-in-or-structure-wrapper-table*
507      (make-hash-table :test 'eq))
508    
509    (defvar wft-type1 nil)
510    (defvar wft-wrapper1 nil)
511    (defvar wft-type2 nil)
512    (defvar wft-wrapper2 nil)
513    
514    (defun wrapper-for-structure (x)
515      (let ((type (structure-type x)))
516        (when (symbolp type)
517          (cond ((eq type 'std-instance)
518                 (return-from wrapper-for-structure (std-instance-wrapper x)))
519                ((eq type wft-type1) (return-from wrapper-for-structure wft-wrapper1))
520                ((eq type wft-type2) (return-from wrapper-for-structure wft-wrapper2))
521                (t (setq wft-type2 wft-type1  wft-wrapper2 wft-wrapper1))))
522        (let* ((cell (find-class-cell type))
523               (class (or (find-class-cell-class cell)
524                          (let* (#+lucid
525                                 (*structure-type* type)
526                                 #+lucid
527                                 (*structure-length* (structure-length x type)))
528                            (find-class-from-cell type cell))))
529               (wrapper (if class (class-wrapper class) *the-wrapper-of-t*)))
530          (when (symbolp type)
531            (setq wft-type1 type  wft-wrapper1 wrapper))
532          wrapper)))
533    
534    (defun built-in-or-structure-wrapper1 (x)
535      (let ((biw (or (built-in-wrapper-of x) *the-wrapper-of-t*)))
536        (or (and (eq biw *the-wrapper-of-t*)
537                 (structurep x)
538                 (let* ((type (type-of x))
539                        #+lucid
540                        (*structure-type* type)
541                        #+lucid
542                        (*structure-length* (structure-length x type))
543                        (class (find-class type nil)))
544                   (and class (class-wrapper class))))
545            biw)))
546    )
547    
548    #|| ; moved to low.lisp
549    (defmacro built-in-or-structure-wrapper (x)
550      (once-only (x)
551        (if (structure-functions-exist-p) ; otherwise structurep is too slow for this
552            `(if (structurep ,x)
553                 (wrapper-for-structure ,x)
554                 (if (symbolp ,x)
555                     (if ,x *the-wrapper-of-symbol* *the-wrapper-of-null*)
556                     (built-in-wrapper-of ,x)))
557            `(or (and (symbolp ,x)
558                      (if ,x *the-wrapper-of-symbol* *the-wrapper-of-null*))
559                 (built-in-or-structure-wrapper1 ,x)))))
560    
561    #-cmu17
562    (defmacro wrapper-of-macro (x)
563      `(cond ((std-instance-p ,x)
564              (std-instance-wrapper ,x))
565             ((fsc-instance-p ,x)
566              (fsc-instance-wrapper ,x))          
567             (t
568              (#+new-kcl-wrapper built-in-wrapper-of
569               #-new-kcl-wrapper built-in-or-structure-wrapper
570               ,x))))
571    
572    #+cmu17
573    (defmacro wrapper-of-macro (x)
574      `(kernel:layout-of ,x))
575    ||#
576    
577    (defun class-of (x)
578      (wrapper-class* (wrapper-of-macro x)))
579    
580    #+cmu17
581    (declaim (inline wrapper-of))
582    (defun wrapper-of (x)
583      (wrapper-of-macro x))
584    
585    #-cmu17
586    (defun structure-wrapper (x)
587      (class-wrapper (find-class (structure-type x))))
588    
589    (defvar find-structure-class nil)
590    
591    (defun eval-form (form)
592      #'(lambda () (eval form)))
593    
594    (defun slot-initargs-from-structure-slotd (slotd)
595      `(:name ,(structure-slotd-name slotd)
596        :defstruct-accessor-symbol ,(structure-slotd-accessor-symbol slotd)
597        :internal-reader-function ,(structure-slotd-reader-function slotd)
598        :internal-writer-function ,(structure-slotd-writer-function slotd)
599        :type ,(or (structure-slotd-type slotd) t)
600        :initform ,(structure-slotd-init-form slotd)
601        :initfunction ,(eval-form (structure-slotd-init-form slotd))))
602    
603    (defun find-structure-class (symbol)
604      (if (structure-type-p symbol)
605          (unless (eq find-structure-class symbol)
606            (let ((find-structure-class symbol))
607              (ensure-class symbol
608                            :metaclass 'structure-class
609                            :name symbol
610                            :direct-superclasses
611                            (when (structure-type-included-type-name symbol)
612                              (list (structure-type-included-type-name symbol)))
613                            :direct-slots
614                            (mapcar #'slot-initargs-from-structure-slotd
615                                    (structure-type-slot-description-list symbol)))))
616          (error "~S is not a legal structure class name." symbol)))
617    
618    #-cmu17
619    (eval-when (compile eval)
620    
621    (defun make-built-in-class-subs ()
622      (mapcar #'(lambda (e)
623                  (let ((class (car e))
624                        (class-subs ()))
625                    (dolist (s *built-in-classes*)
626                      (when (memq class (cadr s)) (pushnew (car s) class-subs)))
627                    (cons class class-subs)))
628              (cons '(t) *built-in-classes*)))
629    
630    (defun make-built-in-class-tree ()
631      (let ((subs (make-built-in-class-subs)))
632        (labels ((descend (class)
633                   (cons class (mapcar #'descend (cdr (assq class subs))))))
634          (descend 't))))
635    
636    (defun make-built-in-wrapper-of-body ()
637      (make-built-in-wrapper-of-body-1 (make-built-in-class-tree)
638                                       'x
639                                       #'get-built-in-wrapper-symbol))
640    
641    (defun make-built-in-wrapper-of-body-1 (tree var get-symbol)
642      (let ((*specials* ()))
643        (declare (special *specials*))
644        (let ((inner (make-built-in-wrapper-of-body-2 tree var get-symbol)))
645          `(locally (declare (special .,*specials*)) ,inner))))
646    
647    (defun make-built-in-wrapper-of-body-2 (tree var get-symbol)
648      (declare (special *specials*))
649      (let ((symbol (funcall get-symbol (car tree))))
650        (push symbol *specials*)
651        (let ((sub-tests
652                (mapcar #'(lambda (x)
653                            (make-built-in-wrapper-of-body-2 x var get-symbol))
654                        (cdr tree))))
655          `(and (typep ,var ',(car tree))
656                ,(if sub-tests
657                     `(or ,.sub-tests ,symbol)
658                     symbol)))))
659    )
660    
661    #-cmu17
662    (defun built-in-wrapper-of (x)
663      #.(when (fboundp 'make-built-in-wrapper-of-body) ; so we can at least read this file
664          (make-built-in-wrapper-of-body)))
665    
666    
667    
668    (defun method-function-returning-nil (args next-methods)
669      (declare (ignore args next-methods))
670      nil)
671    
672    (defun method-function-returning-t (args next-methods)
673      (declare (ignore args next-methods))
674      t)
675    
676    (defun make-class-predicate (class name)
677      (let* ((gf (ensure-generic-function name))
678             (mlist (if (eq *boot-state* 'complete)
679                        (generic-function-methods gf)
680                        (early-gf-methods gf))))
681        (unless mlist
682          (unless (eq class *the-class-t*)
683            (let* ((default-method-function #'method-function-returning-nil)
684                   (default-method-initargs (list :function
685                                                  default-method-function))
686                   (default-method (make-a-method 'standard-method
687                                                  ()
688                                                  (list 'object)
689                                                  (list *the-class-t*)
690                                                  default-method-initargs
691                                                  "class predicate default method")))
692              (setf (method-function-get default-method-function :constant-value) nil)
693              (add-method gf default-method)))
694          (let* ((class-method-function #'method-function-returning-t)
695                 (class-method-initargs (list :function
696                                              class-method-function))
697                 (class-method (make-a-method 'standard-method
698                                              ()
699                                              (list 'object)
700                                              (list class)
701                                              class-method-initargs
702                                              "class predicate class method")))
703            (setf (method-function-get class-method-function :constant-value) t)
704            (add-method gf class-method)))
705        gf))
706    
707    
708    #+cmu17
709    ;;; Set inherits from CPL and register layout.  This actually installs the
710    ;;; class in the lisp type system.
711    ;;;
712    (defun update-lisp-class-layout (class layout)
713      (unless (eq (kernel:class-layout (kernel:layout-class layout))
714                  layout)
715        (setf (kernel:layout-inherits layout)
716              (map 'vector #'class-wrapper
717                   (reverse (rest (class-precedence-list class)))))
718    
719        (kernel:register-layout layout :invalidate nil)))
720    
721    (eval-when (load eval)
722      (clrhash *find-class*)
723      (bootstrap-meta-braid)
724      (bootstrap-accessor-definitions t)
725      (bootstrap-class-predicates t)
726      (bootstrap-accessor-definitions nil)
727      (bootstrap-class-predicates nil)
728      (bootstrap-built-in-classes)
729    
730      #+cmu17
731      (ext:do-hash (name x *find-class*)
732        (let* ((class (find-class-from-cell name x))
733               (layout (class-wrapper class))
734               (lclass (kernel:layout-class layout))
735               (lclass-pcl-class (kernel:class-pcl-class lclass))
736               (olclass (lisp:find-class name nil)))
737          (if lclass-pcl-class
738              (assert (eq class lclass-pcl-class))
739              (setf (kernel:class-pcl-class lclass) class))
740    
741          (update-lisp-class-layout class layout)
742    
743          (cond (olclass
744                 (assert (eq lclass olclass)))
745                (t
746                 (setf (lisp:find-class name) lclass)))))
747    
748      (setq *boot-state* 'braid)
749      )
750    
751    #-cmu17
752    (deftype slot-object ()
753      '(or standard-object structure-object))
754    
755    (defmethod no-applicable-method (generic-function &rest args)
756      (cerror "Retry call to ~S"
757              "No matching method for the generic-function ~S,~@
758              when called with arguments ~S."
759              generic-function args)
760      (apply generic-function args))
761    
762    (defmethod no-next-method ((generic-function standard-generic-function)
763                               (method standard-method)
764                               &rest args)
765      (cerror "Try again."
766              "No next method to ~S when calling generic function ~S with arguments ~S~%"
767              method generic-function args)
768      (apply generic-function args))
769    
770    (defmethod no-primary-method ((generic-function standard-generic-function)
771                                  &rest args)
772      (cerror "Try again."
773              "No primary method when calling generic function ~S with arguments ~S~%"
774              generic-function args)
775      (apply generic-function args))
776    
777    (defmethod invalid-qualifiers ((gf generic-function) combin args methods)
778      (if (null (cdr methods))
779          (error "~@<In a call to ~s with arguments ~:s: ~
780                  The method ~s has invalid qualifiers for method ~
781                  combination ~s.~@:>"
782             gf args (car methods) combin)
783          (error "~@<In a call to ~s with arguments ~:s: ~
784                  The methods ~{~s~^, ~} have invalid qualifiers for ~
785                  method combination ~s.~@:>"
786             gf args methods combin)))
787    
788    (defun %no-primary-method (gf args)
789      (apply #'no-primary-method gf args))
790    
791    (defun %invalid-qualifiers (gf combin args methods)
792      (invalid-qualifiers gf combin args methods))
793    

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