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

Diff of /gcl/pcl/gcl_pcl_defs.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 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    (eval-when (compile load eval)
31      
32    (defvar *defclass-times*   '(load eval))        ;Probably have to change this
33                                                    ;if you use defconstructor.
34    (defvar *defmethod-times*  '(load eval))
35    (defvar *defgeneric-times* '(load eval))
36    
37    ; defvar is now actually in macros
38    ;(defvar *boot-state* ())                       ;NIL
39                                                    ;EARLY
40                                                    ;BRAID
41                                                    ;COMPLETE
42    )
43    
44    (eval-when (load eval)
45      (when (eq *boot-state* 'complete)
46        (error "Trying to load (or compile) PCL in an environment in which it~%~
47                has already been loaded.  This doesn't work, you will have to~%~
48                get a fresh lisp (reboot) and then load PCL."))
49      (when *boot-state*
50        (cerror "Try loading (or compiling) PCL anyways."
51                "Trying to load (or compile) PCL in an environment in which it~%~
52                 has already been partially loaded.  This may not work, you may~%~
53                 need to get a fresh lisp (reboot) and then load PCL."))
54      )
55    
56    
57    
58    ;;;
59    ;;; This is like fdefinition on the Lispm.  If Common Lisp had something like
60    ;;; function specs I wouldn't need this.  On the other hand, I don't like the
61    ;;; way this really works so maybe function specs aren't really right either?
62    ;;;
63    ;;; I also don't understand the real implications of a Lisp-1 on this sort of
64    ;;; thing.  Certainly some of the lossage in all of this is because these
65    ;;; SPECs name global definitions.
66    ;;;
67    ;;; Note that this implementation is set up so that an implementation which
68    ;;; has a 'real' function spec mechanism can use that instead and in that way
69    ;;; get rid of setf generic function names.
70    ;;;
71    (defmacro parse-gspec (spec
72                           (non-setf-var . non-setf-case)
73                           (setf-var . setf-case))
74      (declare (indentation 1 1))
75      #+setf (declare (ignore setf-var setf-case))
76      (once-only (spec)
77        `(cond (#-setf (symbolp ,spec) #+setf t
78                (let ((,non-setf-var ,spec)) ,@non-setf-case))
79               #-setf
80               ((and (listp ,spec)
81                     (eq (car ,spec) 'setf)
82                     (symbolp (cadr ,spec)))
83                (let ((,setf-var (cadr ,spec))) ,@setf-case))
84               #-setf
85               (t
86                (error
87                  "Can't understand ~S as a generic function specifier.~%~
88                   It must be either a symbol which can name a function or~%~
89                   a list like ~S, where the car is the symbol ~S and the cadr~%~
90                   is a symbol which can name a generic function."
91                  ,spec '(setf <foo>) 'setf)))))
92    
93    ;;;
94    ;;; If symbol names a function which is traced or advised, return the
95    ;;; unadvised, traced etc. definition.  This lets me get at the generic
96    ;;; function object even when it is traced.
97    ;;;
98    (defun unencapsulated-fdefinition (symbol)
99      #+Lispm (si:fdefinition (si:unencapsulate-function-spec symbol))
100      #+Lucid (lucid::get-unadvised-procedure (symbol-function symbol))
101      #+excl  (or (excl::encapsulated-basic-definition symbol)
102                  (symbol-function symbol))
103      #+xerox (il:virginfn symbol)
104      #+setf (fdefinition symbol)
105    ;  #+kcl (symbol-function
106    ;         (let ((sym (when (symbolp symbol) (get symbol 'si::traced))) first-form)
107    ;           (if (and sym
108    ;                    (consp (symbol-function symbol))
109    ;                    (consp (setq first-form (nth 3 (symbol-function symbol))))
110    ;                    (eq (car first-form) 'si::trace-call))
111    ;               sym
112    ;               symbol)))
113      #-(or Lispm Lucid excl Xerox setf kcl) (symbol-function symbol))
114    
115    ;;;
116    ;;; If symbol names a function which is traced or advised, redefine
117    ;;; the `real' definition without affecting the advise.
118    ;;;
119    (defun fdefine-carefully (name new-definition)
120      #+Lispm (si:fdefine name new-definition t t)
121      #+Lucid (let ((lucid::*redefinition-action* nil))
122                (setf (symbol-function name) new-definition))
123      #+excl  (setf (symbol-function name) new-definition)
124      #+xerox (let ((advisedp (member name il:advisedfns :test #'eq))
125                    (brokenp (member name il:brokenfns :test #'eq)))
126                ;; In XeroxLisp (late of envos) tracing is implemented
127                ;; as a special case of "breaking".  Advising, however,
128                ;; is treated specially.
129                (xcl:unadvise-function name :no-error t)
130                (xcl:unbreak-function name :no-error t)
131                (setf (symbol-function name) new-definition)
132                (when brokenp (xcl:rebreak-function name))
133                (when advisedp (xcl:readvise-function name)))
134      ;; FIXME add setf expander for fdefinition -- right now we go through
135      ;; the following code which expands to a call to si::fset
136      #+(and setf (not cmu) (not kcl)) (setf (fdefinition name) new-definition)
137      #+kcl (setf (symbol-function
138                   (let ((sym (when (symbolp name) (get name 'si::traced))) first-form)
139                     (if (and sym
140                              (consp (symbol-function name))
141                              (consp (setq first-form
142                                           (nth 3 (symbol-function name))))
143                              (eq (car first-form) 'si::trace-call))
144                         sym
145                         name)))
146                  new-definition)
147      #+cmu (progn
148              (c::%%defun name new-definition nil)
149              (c::note-name-defined name :function)
150              new-definition)
151      #-(or Lispm Lucid excl Xerox setf kcl cmu)
152      (setf (symbol-function name) new-definition))
153    
154    (defun gboundp (spec)
155      (parse-gspec spec
156        (name (fboundp name))
157        (name (fboundp (get-setf-function-name name)))))
158    
159    (defun gmakunbound (spec)
160      (parse-gspec spec
161        (name (fmakunbound name))
162        (name (fmakunbound (get-setf-function-name name)))))
163    
164    (defun gdefinition (spec)
165      (parse-gspec spec
166        (name (or #-setf (macro-function name)              ;??
167                  (unencapsulated-fdefinition name)))
168        (name (unencapsulated-fdefinition (get-setf-function-name name)))))
169    
170    (defun #-setf SETF\ PCL\ GDEFINITION #+setf (setf gdefinition) (new-value spec)
171      (parse-gspec spec
172        (name (fdefine-carefully name new-value))
173        (name (fdefine-carefully (get-setf-function-name name) new-value))))
174    
175    
176    (proclaim '(special *the-class-t*
177                        *the-class-vector* *the-class-symbol*
178                        *the-class-string* *the-class-sequence*
179                        *the-class-rational* *the-class-ratio*
180                        *the-class-number* *the-class-null* *the-class-list*
181                        *the-class-integer* *the-class-float* *the-class-cons*
182                        *the-class-complex* *the-class-character*
183                        *the-class-bit-vector* *the-class-array*
184    
185                        *the-class-slot-object*
186                        *the-class-standard-object*
187                        *the-class-structure-object*
188                        *the-class-class*
189                        *the-class-generic-function*
190                        *the-class-built-in-class*
191                        *the-class-slot-class*
192                        *the-class-structure-class*
193                        *the-class-standard-class*
194                        *the-class-funcallable-standard-class*
195                        *the-class-method*
196                        *the-class-standard-method*
197                        *the-class-standard-reader-method*
198                        *the-class-standard-writer-method*
199                        *the-class-standard-boundp-method*
200                        *the-class-standard-generic-function*
201                        *the-class-standard-effective-slot-definition*
202    
203                        *the-eslotd-standard-class-slots*
204                        *the-eslotd-funcallable-standard-class-slots*))
205    
206    (proclaim '(special *the-wrapper-of-t*
207                        *the-wrapper-of-vector* *the-wrapper-of-symbol*
208                        *the-wrapper-of-string* *the-wrapper-of-sequence*
209                        *the-wrapper-of-rational* *the-wrapper-of-ratio*
210                        *the-wrapper-of-number* *the-wrapper-of-null*
211                        *the-wrapper-of-list* *the-wrapper-of-integer*
212                        *the-wrapper-of-float* *the-wrapper-of-cons*
213                        *the-wrapper-of-complex* *the-wrapper-of-character*
214                        *the-wrapper-of-bit-vector* *the-wrapper-of-array*))
215    
216    ;;;; Type specifier hackery:
217    
218    ;;; internal to this file.
219    (defun coerce-to-class (class &optional make-forward-referenced-class-p)
220      (if (symbolp class)
221          (or (find-class class (not make-forward-referenced-class-p))
222              (ensure-class class))
223          class))
224    
225    ;;; Interface
226    (defun specializer-from-type (type &aux args)
227      (when (consp type)
228        (setq args (cdr type) type (car type)))
229      (cond ((symbolp type)
230             (or (and (null args) (find-class type))
231                 (ecase type
232                   (class    (coerce-to-class (car args)))
233                   (prototype (make-instance 'class-prototype-specializer
234                                             :object (coerce-to-class (car args))))
235                   (class-eq (class-eq-specializer (coerce-to-class (car args))))
236                   (eql      (intern-eql-specializer (car args))))))
237            #+cmu17
238            ((and (null args) (typep type 'lisp:class))
239             (or (kernel:class-pcl-class type)
240                 (find-structure-class (lisp:class-name type))))
241            ((specializerp type) type)))
242    
243    ;;; interface
244    (defun type-from-specializer (specl)
245      (cond ((eq specl 't)
246             't)
247            ((consp specl)
248             (unless (member (car specl) '(class prototype class-eq eql))
249               (error "~S is not a legal specializer type" specl))
250             specl)
251            ((progn
252               (when (symbolp specl)
253                 ;;maybe (or (find-class specl nil) (ensure-class specl)) instead?
254                 (setq specl (find-class specl)))
255               (or (not (eq *boot-state* 'complete))
256                   (specializerp specl)))
257             (specializer-type specl))
258            (t
259             (error "~s is neither a type nor a specializer" specl))))
260    
261    (defun type-class (type)
262      (declare (special *the-class-t*))
263      (setq type (type-from-specializer type))
264      (if (atom type)
265          (if (eq type 't)
266              *the-class-t*
267              (error "bad argument to type-class"))
268          (case (car type)
269            (eql (class-of (cadr type)))
270            (prototype (class-of (cadr type))) ;?
271            (class-eq (cadr type))
272            (class (cadr type)))))
273    
274    (defun class-eq-type (class)
275      (specializer-type (class-eq-specializer class)))
276    
277    (defun inform-type-system-about-std-class (name)
278      (let ((predicate-name (make-type-predicate-name name)))
279        (setf (gdefinition predicate-name) (make-type-predicate name))
280        (do-satisfies-deftype name predicate-name)))
281    
282    (defun make-type-predicate (name)
283      (let ((cell (find-class-cell name)))
284        #'(lambda (x)
285            (funcall (the function (find-class-cell-predicate cell)) x))))
286    
287    
288    ;This stuff isn't right.  Good thing it isn't used.
289    ;The satisfies predicate has to be a symbol.  There is no way to
290    ;construct such a symbol from a class object if class names change.
291    (defun class-predicate (class)
292      (when (symbolp class) (setq class (find-class class)))
293      #'(lambda (object) (memq class (class-precedence-list (class-of object)))))
294    
295    (defun make-class-eq-predicate (class)
296      (when (symbolp class) (setq class (find-class class)))
297      #'(lambda (object) (eq class (class-of object))))
298    
299    (defun make-eql-predicate (eql-object)
300      #'(lambda (object) (eql eql-object object)))
301    
302    #|| ; The argument to satisfies must be a symbol.  
303    (deftype class (&optional class)
304      (if class
305          `(satisfies ,(class-predicate class))
306          `(satisfies ,(class-predicate 'class))))
307    
308    (deftype class-eq (class)
309      `(satisfies ,(make-class-eq-predicate class)))
310    ||#
311    
312    #-(or excl cmu17)
313    (deftype eql (type-object)
314      `(member ,type-object))
315    
316    
317    ;;; Internal to this file.
318    ;;;
319    ;;; These functions are a pale imitiation of their namesake.  They accept
320    ;;; class objects or types where they should.
321    ;;;
322    (defun *normalize-type (type)
323      (cond ((consp type)
324             (if (member (car type) '(not and or))
325                 `(,(car type) ,@(mapcar #'*normalize-type (cdr type)))
326                 (if (null (cdr type))
327                     (*normalize-type (car type))
328                     type)))
329            ((symbolp type)
330             (let ((class (find-class type nil)))
331               (if class
332                   (let ((type (specializer-type class)))
333                     (if (listp type) type `(,type)))
334                   `(,type))))
335            ((or (not (eq *boot-state* 'complete))
336                 (specializerp type))
337             (specializer-type type))
338            (t
339             (error "~s is not a type" type))))
340    
341    ;;; Not used...
342    #+nil
343    (defun unparse-type-list (tlist)
344      (mapcar #'unparse-type tlist))
345    
346    ;;; Not used...
347    #+nil
348    (defun unparse-type (type)
349      (if (atom type)
350          (if (specializerp type)
351              (unparse-type (specializer-type type))
352              type)
353          (case (car type)
354            (eql type)
355            (class-eq `(class-eq ,(class-name (cadr type))))
356            (class (class-name (cadr type)))
357            (t `(,(car type) ,@(unparse-type-list (cdr type)))))))
358    
359    ;;; internal to this file...
360    (defun convert-to-system-type (type)
361      (case (car type)
362        ((not and or) `(,(car type) ,@(mapcar #'convert-to-system-type
363                                              (cdr type))))
364        ((class class-eq) ; class-eq is impossible to do right
365         #-cmu17 (class-name (cadr type))
366         #+cmu17 (kernel:layout-class (class-wrapper (cadr type))))
367        (eql type)
368        (t (if (null (cdr type))
369               (car type)
370               type))))
371    
372    ;;; not used...
373    #+nil
374    (defun *typep (object type)
375      (setq type (*normalize-type type))
376      (cond ((member (car type) '(eql wrapper-eq class-eq class))
377             (specializer-applicable-using-type-p type `(eql ,object)))
378            ((eq (car type) 'not)
379             (not (*typep object (cadr type))))
380            (t
381             (typep object (convert-to-system-type type)))))
382    
383    
384    ;;; *SUBTYPEP  --  Interface
385    ;;;
386    ;Writing the missing NOT and AND clauses will improve
387    ;the quality of code generated by generate-discrimination-net, but
388    ;calling subtypep in place of just returning (values nil nil) can be
389    ;very slow.  *subtypep is used by PCL itself, and must be fast.
390    (defun *subtypep (type1 type2)
391      (if (equal type1 type2)
392          (values t t)
393          (if (eq *boot-state* 'early)
394              (values (eq type1 type2) t)
395              (let ((*in-precompute-effective-methods-p* t))
396                (declare (special *in-precompute-effective-methods-p*))
397                ;; *in-precompute-effective-methods-p* is not a good name.
398                ;; It changes the way class-applicable-using-class-p works.
399                (setq type1 (*normalize-type type1))
400                (setq type2 (*normalize-type type2))
401                (case (car type2)
402                  (not
403                   (values nil nil)) ; Should improve this.
404                  (and
405                   (values nil nil)) ; Should improve this.
406                  ((eql wrapper-eq class-eq class)
407                   (multiple-value-bind (app-p maybe-app-p)
408                       (specializer-applicable-using-type-p type2 type1)
409                     (values app-p (or app-p (not maybe-app-p)))))
410                  (t
411                   (subtypep (convert-to-system-type type1)
412                             (convert-to-system-type type2))))))))
413    
414    (defun do-satisfies-deftype (name predicate)
415      #+cmu17 (declare (ignore name predicate))
416      #+(or :Genera (and :Lucid (not :Prime)) ExCL :coral)
417      (let* ((specifier `(satisfies ,predicate))
418             (expand-fn #'(lambda (&rest ignore)
419                            (declare (ignore ignore))
420                            specifier)))
421        ;; Specific ports can insert their own way of doing this.  Many
422        ;; ports may find the expand-fn defined above useful.
423        ;;
424        (or #+:Genera
425            (setf (get name 'deftype) expand-fn)
426            #+(and :Lucid (not :Prime))
427            (system::define-macro `(deftype ,name) expand-fn nil)
428            #+ExCL
429            (setf (get name 'excl::deftype-expander) expand-fn)
430            #+:coral
431            (setf (get name 'ccl::deftype-expander) expand-fn)))
432      #-(or :Genera (and :Lucid (not :Prime)) ExCL :coral cmu17)
433      ;; This is the default for ports for which we don't know any
434      ;; better.  Note that for most ports, providing this definition
435      ;; should just speed up class definition.  It shouldn't have an
436      ;; effect on performance of most user code.
437      (eval `(deftype ,name () '(satisfies ,predicate))))
438    
439    (defun make-type-predicate-name (name &optional kind)
440      (if (symbol-package name)
441          (intern (format nil
442                          "~@[~A ~]TYPE-PREDICATE ~A ~A"
443                          kind
444                          (package-name (symbol-package name))
445                          (symbol-name name))
446                  *the-pcl-package*)
447          (make-symbol (format nil
448                               "~@[~A ~]TYPE-PREDICATE ~A"
449                               kind
450                               (symbol-name name)))))
451    
452    
453    
454    (defvar *built-in-class-symbols* ())
455    (defvar *built-in-wrapper-symbols* ())
456    
457    (defun get-built-in-class-symbol (class-name)
458      (or (cadr (assq class-name *built-in-class-symbols*))
459          (let ((symbol (intern (format nil
460                                        "*THE-CLASS-~A*"
461                                        (symbol-name class-name))
462                                *the-pcl-package*)))
463            (push (list class-name symbol) *built-in-class-symbols*)
464            symbol)))
465    
466    (defun get-built-in-wrapper-symbol (class-name)
467      (or (cadr (assq class-name *built-in-wrapper-symbols*))
468          (let ((symbol (intern (format nil
469                                        "*THE-WRAPPER-OF-~A*"
470                                        (symbol-name class-name))
471                                *the-pcl-package*)))
472            (push (list class-name symbol) *built-in-wrapper-symbols*)
473            symbol)))
474    
475    
476    
477    
478    (pushnew 'class *variable-declarations*)
479    (pushnew 'variable-rebinding *variable-declarations*)
480    
481    (defun variable-class (var env)
482      (caddr (variable-declaration 'class var env)))
483    
484    (defvar *name->class->slotd-table* (make-hash-table))
485    
486    
487    ;;;
488    ;;; This is used by combined methods to communicate the next methods to
489    ;;; the methods they call.  This variable is captured by a lexical variable
490    ;;; of the methods to give it the proper lexical scope.
491    ;;;
492    (defvar *next-methods* nil)
493    
494    (defvar *not-an-eql-specializer* '(not-an-eql-specializer))
495    
496    (defvar *umi-gfs*)
497    (defvar *umi-complete-classes*)
498    (defvar *umi-reorder*)
499    
500    (defvar *invalidate-discriminating-function-force-p* ())
501    (defvar *invalid-dfuns-on-stack* ())
502    
503    
504    (defvar *standard-method-combination*)
505    
506    (defvar *slotd-unsupplied* (list '*slotd-unsupplied*))  ;***
507    
508    
509    (defmacro define-gf-predicate (predicate-name &rest classes)
510      `(progn
511         (defmethod ,predicate-name ((x t)) nil)
512         ,@(mapcar #'(lambda (c) `(defmethod ,predicate-name ((x ,c)) t))
513                   classes)))
514    
515    (defun make-class-predicate-name (name)
516      (intern (format nil "~A::~A class predicate"
517                      (package-name (symbol-package name))
518                      name)
519              *the-pcl-package*))
520    
521    (defun plist-value (object name)
522      (getf (object-plist object) name))
523    
524    (defun #-setf SETF\ PCL\ PLIST-VALUE #+setf (setf plist-value) (new-value object name)
525      (if new-value
526          (setf (getf (object-plist object) name) new-value)
527          (progn
528            (remf (object-plist object) name)
529            nil)))
530    
531    
532    
533    (defvar *built-in-classes*
534      ;;
535      ;; name       supers     subs                     cdr of cpl
536      ;; prototype
537      '(;(t         ()         (number sequence array character symbol) ())
538        (number     (t)        (complex float rational) (t))
539        (complex    (number)   ()                       (number t)
540         #c(1 1))
541        (float      (real)     ()                       (real number t)
542         1.0)
543        (real       (number)   (rational float)         (number t))
544        (rational   (real)     (integer ratio)          (real number t))
545        (integer    (rational) ()                       (rational real number t)
546         1)
547        (ratio      (rational) ()                       (rational real number t)
548         1/2)
549    
550        (sequence   (t)        (list vector)            (t))
551        (list       (sequence) (cons null)              (sequence t))
552        (cons       (list)     ()                       (list sequence t)
553         (nil))
554        
555    
556        (array      (t)        (vector)                 (t)
557         #2A((NIL)))
558        (vector     (array
559                     sequence) (string bit-vector)      (array sequence t)
560         #())
561        (string     (vector)   ()                       (vector array sequence t)
562         "")
563        (bit-vector (vector)   ()                       (vector array sequence t)
564         #*1)
565        (character  (t)        ()                       (t)
566         #\c)
567      
568        (symbol     (t)        (null)                   (t)
569         symbol)
570        (null       (symbol
571                     list)     ()                       (symbol list sequence t)
572         nil)))
573    
574    #+cmu17
575    (labels ((direct-supers (class)
576               (if (typep class 'lisp:built-in-class)
577                   (kernel:built-in-class-direct-superclasses class)
578                   (let ((inherits (kernel:layout-inherits
579                                    (kernel:class-layout class))))
580                     (list (svref inherits (1- (length inherits)))))))
581             (direct-subs (class)
582               (ext:collect ((res))
583                 (let ((subs (kernel:class-subclasses class)))
584                   (when subs
585                     (ext:do-hash (sub v subs)
586                       (declare (ignore v))
587                       (when (member class (direct-supers sub))
588                         (res sub)))))
589                 (res))))
590      (ext:collect ((res))
591        (dolist (bic kernel::built-in-classes)
592          (let* ((name (car bic))
593                 (class (lisp:find-class name)))
594            (unless (member name '(t kernel:instance kernel:funcallable-instance
595                                     function))
596              (res `(,name
597                     ,(mapcar #'lisp:class-name (direct-supers class))
598                     ,(mapcar #'lisp:class-name (direct-subs class))
599                     ,(map 'list #'(lambda (x)
600                                     (lisp:class-name (kernel:layout-class x)))
601                           (reverse
602                            (kernel:layout-inherits
603                             (kernel:class-layout class))))
604                     ,(let ((found (assoc name *built-in-classes*)))
605                        (if found (fifth found) 42)))))))
606        (setq *built-in-classes* (res))))
607    
608    
609    ;;;
610    ;;; The classes that define the kernel of the metabraid.
611    ;;;
612    (defclass t () ()
613      (:metaclass built-in-class))
614    
615    #+cmu17
616    (progn
617      (defclass kernel:instance (t) ()
618        (:metaclass built-in-class))
619      
620      (defclass function (t) ()
621        (:metaclass built-in-class))
622    
623      (defclass kernel:funcallable-instance (function) ()
624        (:metaclass built-in-class)))
625    
626    (defclass slot-object (#-cmu17 t #+cmu17 kernel:instance) ()
627      (:metaclass slot-class))
628    
629    (defclass structure-object (slot-object) ()
630      (:metaclass structure-class))
631    
632    (defstruct (#-cmu17 structure-object #+cmu17 dead-beef-structure-object
633                 (:constructor |STRUCTURE-OBJECT class constructor|)))
634    
635    
636    (defclass standard-object (slot-object) ())
637    
638    (defclass metaobject (standard-object) ())
639    
640    (defclass specializer (metaobject)
641         ((type
642            :initform nil
643            :reader specializer-type)))
644    
645    (defclass definition-source-mixin (standard-object)
646         ((source
647            :initform (load-truename)
648            :reader definition-source
649            :initarg :definition-source)))
650    
651    (defclass plist-mixin (standard-object)
652         ((plist
653            :initform ()
654            :accessor object-plist)))
655    
656    (defclass documentation-mixin (plist-mixin)
657         ())
658    
659    (defclass dependent-update-mixin (plist-mixin)
660        ())
661    
662    ;;;
663    ;;; The class CLASS is a specified basic class.  It is the common superclass
664    ;;; of any kind of class.  That is any class that can be a metaclass must
665    ;;; have the class CLASS in its class precedence list.
666    ;;;
667    (defclass class (documentation-mixin dependent-update-mixin definition-source-mixin
668                     specializer)
669         ((name
670            :initform nil
671            :initarg  :name
672            :accessor class-name)
673          (class-eq-specializer
674            :initform nil
675            :reader class-eq-specializer)
676          (direct-superclasses
677            :initform ()
678            :reader class-direct-superclasses)
679          (direct-subclasses
680            :initform ()
681            :reader class-direct-subclasses)
682          (direct-methods
683            :initform (cons nil nil))
684          (predicate-name
685            :initform nil
686            :reader class-predicate-name)))
687    
688    ;;;
689    ;;; The class PCL-CLASS is an implementation-specific common superclass of
690    ;;; all specified subclasses of the class CLASS.
691    ;;;
692    (defclass pcl-class (class)
693         ((class-precedence-list
694            :reader class-precedence-list)
695          (can-precede-list
696            :initform ()
697            :reader class-can-precede-list)
698          (incompatible-superclass-list
699            :initform ()
700            :accessor class-incompatible-superclass-list)
701          (wrapper
702            :initform nil
703            :reader class-wrapper)
704          (prototype
705            :initform nil
706            :reader class-prototype)))
707    
708    (defclass slot-class (pcl-class)
709         ((direct-slots
710            :initform ()
711            :accessor class-direct-slots)
712          (slots
713            :initform ()
714            :accessor class-slots)
715          (initialize-info
716            :initform nil
717            :accessor class-initialize-info)))
718    
719    ;;;
720    ;;; The class STD-CLASS is an implementation-specific common superclass of
721    ;;; the classes STANDARD-CLASS and FUNCALLABLE-STANDARD-CLASS.
722    ;;;
723    (defclass std-class (slot-class)
724         ())
725    
726    (defclass standard-class (std-class)
727         ())
728    
729    (defclass funcallable-standard-class (std-class)
730         ())
731        
732    (defclass forward-referenced-class (pcl-class) ())
733    
734    (defclass built-in-class (pcl-class) ())
735    
736    (defclass structure-class (slot-class)
737         ((defstruct-form
738            :initform ()
739            :accessor class-defstruct-form)
740          (defstruct-constructor
741            :initform nil
742            :accessor class-defstruct-constructor)
743          (from-defclass-p
744            :initform nil
745            :initarg :from-defclass-p)))
746        
747    
748    (defclass specializer-with-object (specializer) ())
749    
750    (defclass exact-class-specializer (specializer) ())
751    
752    (defclass class-eq-specializer (exact-class-specializer specializer-with-object)
753      ((object :initarg :class :reader specializer-class :reader specializer-object)))
754    
755    (defclass class-prototype-specializer (specializer-with-object)
756      ((object :initarg :class :reader specializer-class :reader specializer-object)))
757    
758    (defclass eql-specializer (exact-class-specializer specializer-with-object)
759      ((object :initarg :object :reader specializer-object
760               :reader eql-specializer-object)))
761    
762    (defvar *eql-specializer-table* (make-hash-table :test 'eql))
763    
764    (defun intern-eql-specializer (object)
765      (or (gethash object *eql-specializer-table*)
766          (setf (gethash object *eql-specializer-table*)
767                (make-instance 'eql-specializer :object object))))
768    
769    
770    ;;;
771    ;;; Slot definitions.
772    ;;;
773    (defclass slot-definition (metaobject)
774         ((name
775            :initform nil
776            :initarg :name
777            :accessor slot-definition-name)
778          (initform
779            :initform nil
780            :initarg :initform
781            :accessor slot-definition-initform)
782          (initfunction
783            :initform nil
784            :initarg :initfunction
785            :accessor slot-definition-initfunction)
786          (readers
787            :initform nil
788            :initarg :readers
789            :accessor slot-definition-readers)
790          (writers
791            :initform nil
792            :initarg :writers
793            :accessor slot-definition-writers)
794          (initargs
795            :initform nil
796            :initarg :initargs
797            :accessor slot-definition-initargs)
798          (type
799            :initform t
800            :initarg :type
801            :accessor slot-definition-type)
802          (documentation
803            :initform ""
804            :initarg :documentation)
805          (class
806            :initform nil
807            :initarg :class
808            :accessor slot-definition-class)))
809    
810    (defclass standard-slot-definition (slot-definition)
811      ((allocation
812        :initform :instance
813        :initarg :allocation
814        :accessor slot-definition-allocation)))
815    
816    (defclass structure-slot-definition (slot-definition)
817      ((defstruct-accessor-symbol
818         :initform nil
819         :initarg :defstruct-accessor-symbol
820         :accessor slot-definition-defstruct-accessor-symbol)
821       (internal-reader-function
822         :initform nil
823         :initarg :internal-reader-function
824         :accessor slot-definition-internal-reader-function)
825       (internal-writer-function
826         :initform nil
827         :initarg :internal-writer-function
828         :accessor slot-definition-internal-writer-function)))
829    
830    (defclass direct-slot-definition (slot-definition)
831      ())
832    
833    (defclass effective-slot-definition (slot-definition)
834      ((reader-function ; #'(lambda (object) ...)
835        :accessor slot-definition-reader-function)
836       (writer-function ; #'(lambda (new-value object) ...)
837        :accessor slot-definition-writer-function)
838       (boundp-function ; #'(lambda (object) ...)
839        :accessor slot-definition-boundp-function)
840       (accessor-flags
841        :initform 0)))
842    
843    (defclass standard-direct-slot-definition (standard-slot-definition
844                                               direct-slot-definition)
845      ())
846    
847    (defclass standard-effective-slot-definition (standard-slot-definition
848                                                  effective-slot-definition)
849      ((location ; nil, a fixnum, a cons: (slot-name . value)
850        :initform nil
851        :accessor slot-definition-location)))
852    
853    (defclass structure-direct-slot-definition (structure-slot-definition
854                                                direct-slot-definition)
855      ())
856    
857    (defclass structure-effective-slot-definition (structure-slot-definition
858                                                   effective-slot-definition)
859      ())
860    
861    (defclass method (metaobject) ())
862    
863    (defclass standard-method (definition-source-mixin plist-mixin method)
864         ((generic-function
865            :initform nil  
866            :accessor method-generic-function)
867    ;     (qualifiers
868    ;       :initform ()
869    ;       :initarg  :qualifiers
870    ;       :reader method-qualifiers)
871          (specializers
872            :initform ()
873            :initarg  :specializers
874            :reader method-specializers)
875          (lambda-list
876            :initform ()
877            :initarg  :lambda-list
878            :reader method-lambda-list)
879          (function
880            :initform nil
881            :initarg :function)             ;no writer
882          (fast-function
883            :initform nil
884            :initarg :fast-function         ;no writer
885            :reader method-fast-function)
886    ;     (documentation
887    ;       :initform nil
888    ;       :initarg  :documentation
889    ;       :reader method-documentation)
890          ))
891    
892    (defclass standard-accessor-method (standard-method)
893         ((slot-name :initform nil
894                     :initarg :slot-name
895                     :reader accessor-method-slot-name)
896          (slot-definition :initform nil
897                           :initarg :slot-definition
898                           :reader accessor-method-slot-definition)))
899    
900    (defclass standard-reader-method (standard-accessor-method) ())
901    
902    (defclass standard-writer-method (standard-accessor-method) ())
903    
904    (defclass standard-boundp-method (standard-accessor-method) ())
905    
906    (defclass generic-function (dependent-update-mixin
907                                definition-source-mixin
908                                documentation-mixin
909                                metaobject
910                                #+cmu17 kernel:funcallable-instance)
911         ()
912      (:metaclass funcallable-standard-class))
913        
914    (defclass standard-generic-function (generic-function)
915         ((name
916            :initform nil
917            :initarg :name
918            :accessor generic-function-name)
919          (methods
920            :initform ()
921            :accessor generic-function-methods)
922          (method-class
923            :initarg :method-class
924            :accessor generic-function-method-class)
925          (method-combination
926            :initarg :method-combination
927            :accessor generic-function-method-combination)
928          (arg-info
929            :initform (make-arg-info)
930            :reader gf-arg-info)
931          (dfun-state
932            :initform ()
933            :accessor gf-dfun-state)
934          (pretty-arglist
935            :initform ()
936            :accessor gf-pretty-arglist)
937          )
938      (:metaclass funcallable-standard-class)
939      (:default-initargs :method-class *the-class-standard-method*
940                         :method-combination *standard-method-combination*))
941    
942    (defclass method-combination (metaobject) ())
943    
944    (defclass standard-method-combination
945              (definition-source-mixin method-combination)
946         ((type          :reader method-combination-type
947                         :initarg :type)
948          (documentation :reader method-combination-documentation
949                         :initarg :documentation)
950          (options       :reader method-combination-options
951                         :initarg :options)))
952    
953    (defclass long-method-combination (standard-method-combination)
954      ((function
955        :initarg :function
956        :reader long-method-combination-function)
957       (arguments-lambda-list
958        :initarg :arguments-lambda-list
959        :reader long-method-combination-arguments-lambda-list)))
960    
961    (defparameter *early-class-predicates*
962      '((specializer specializerp)
963        (exact-class-specializer exact-class-specializer-p)
964        (class-eq-specializer class-eq-specializer-p)
965        (eql-specializer eql-specializer-p)
966        (class classp)
967        (slot-class slot-class-p)
968        (standard-class standard-class-p)
969        (funcallable-standard-class funcallable-standard-class-p)
970        (structure-class structure-class-p)
971        (forward-referenced-class forward-referenced-class-p)
972        (method method-p)
973        (standard-method standard-method-p)
974        (standard-accessor-method standard-accessor-method-p)
975        (standard-reader-method standard-reader-method-p)
976        (standard-writer-method standard-writer-method-p)
977        (standard-boundp-method standard-boundp-method-p)
978        (generic-function generic-function-p)
979        (standard-generic-function standard-generic-function-p)
980        (method-combination method-combination-p)
981        (long-method-combination long-method-combination-p)))
982    

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