/[cmucl]/src/pcl/defs.lisp
ViewVC logotype

Diff of /src/pcl/defs.lisp

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

revision 1.33.2.3 by gerd, Sun Mar 16 13:10:16 2003 UTC revision 1.33.2.4 by gerd, Wed Mar 19 16:33:23 2003 UTC
# Line 139  Line 139 
139                 (class    (coerce-to-class (car args)))                 (class    (coerce-to-class (car args)))
140                 (class-eq (class-eq-specializer (coerce-to-class (car args))))                 (class-eq (class-eq-specializer (coerce-to-class (car args))))
141                 (eql      (intern-eql-specializer (car args))))))                 (eql      (intern-eql-specializer (car args))))))
142          ((and (null args) (typep type 'lisp:class))          ((and (null args) (typep type 'kernel::class))
143           (or (kernel:class-pcl-class type)           (or (kernel:%class-pcl-class type)
144               (find-structure-class (lisp:class-name type))))               (find-structure-class (kernel:%class-name type))))
145          ((specializerp type) type)))          ((specializerp type) type)))
146    
147  ;;; interface  ;;; interface
# Line 190  Line 190 
190    ;; Earlier revisions (<= 1.17) of this function were essentially NOOPs.    ;; Earlier revisions (<= 1.17) of this function were essentially NOOPs.
191    (declare (ignorable name))    (declare (ignorable name))
192    (when (and (eq *boot-state* 'complete)    (when (and (eq *boot-state* 'complete)
193               (null (lisp:find-class name nil)))               (null (kernel::find-class name nil)))
194      (setf (lisp:find-class name)      (setf (kernel::find-class name)
195            (lisp::make-standard-class :name name))))            (kernel::make-standard-class :name name))))
196    
197  ;;; Internal to this file.  ;;; Internal to this file.
198  ;;;  ;;;
# Line 347  Line 347 
347       nil)))       nil)))
348    
349  (labels ((direct-supers (class)  (labels ((direct-supers (class)
350             (if (typep class 'lisp:built-in-class)             (if (typep class 'kernel::built-in-class)
351                 (kernel:built-in-class-direct-superclasses class)                 (kernel:built-in-class-direct-superclasses class)
352                 (let ((inherits (kernel:layout-inherits                 (let ((inherits (kernel:layout-inherits
353                                  (kernel:class-layout class))))                                  (kernel:%class-layout class))))
354                   (list (svref inherits (1- (length inherits)))))))                   (list (svref inherits (1- (length inherits)))))))
355           (direct-subs (class)           (direct-subs (class)
356             (ext:collect ((res))             (ext:collect ((res))
357               (let ((subs (kernel:class-subclasses class)))               (let ((subs (kernel:%class-subclasses class)))
358                 (when subs                 (when subs
359                   (ext:do-hash (sub v subs)                   (ext:do-hash (sub v subs)
360                     (declare (ignore v))                     (declare (ignore v))
# Line 364  Line 364 
364    (ext:collect ((res))    (ext:collect ((res))
365      (dolist (bic kernel::built-in-classes)      (dolist (bic kernel::built-in-classes)
366        (let* ((name (car bic))        (let* ((name (car bic))
367               (class (lisp:find-class name)))               (class (kernel::find-class name)))
368          (unless (member name '(t kernel:instance kernel:funcallable-instance          (unless (member name '(t kernel:instance kernel:funcallable-instance
369                                   function stream))                                   function stream))
370            (res `(,name            (res `(,name
371                   ,(mapcar #'lisp:class-name (direct-supers class))                   ,(mapcar #'kernel:%class-name (direct-supers class))
372                   ,(mapcar #'lisp:class-name (direct-subs class))                   ,(mapcar #'kernel:%class-name (direct-subs class))
373                   ,(map 'list (lambda (x)                   ,(map 'list (lambda (x)
374                                 (lisp:class-name (kernel:layout-class x)))                                 (kernel:%class-name (kernel:layout-class x)))
375                         (reverse                         (reverse
376                          (kernel:layout-inherits                          (kernel:layout-inherits
377                           (kernel:class-layout class))))                           (kernel:%class-layout class))))
378                   ,(let ((found (assoc name *built-in-classes*)))                   ,(let ((found (assoc name *built-in-classes*)))
379                      (if found (fifth found) 42)))))))                      (if found (fifth found) 42)))))))
380      (setq *built-in-classes* (res))))      (setq *built-in-classes* (res))))

Legend:
Removed from v.1.33.2.3  
changed lines
  Added in v.1.33.2.4

  ViewVC Help
Powered by ViewVC 1.1.5