Changeset 7727


Ignore:
Timestamp:
Nov 25, 2007, 2:27:39 AM (12 years ago)
Author:
gb
Message:

New class-cell stuff.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • branches/working-0711/ccl/level-1/l1-clos-boot.lisp

    r7301 r7727  
    920920        (unless found (return))
    921921        (when (cdr cell)
    922           (funcall function name (cdr cell)))))))
     922          (funcall function name (class-cell-class cell)))))))
    923923
    924924
     
    11731173
    11741174
     1175
     1176
    11751177                       
    11761178;;;;;;;;;;;;;;;;;;;;;;;;  Instances and classes ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     
    11791181
    11801182(defun class-cell-typep (form class-cell)
    1181   (unless (listp class-cell)(error "puke"))
    1182   (locally (declare (type list class-cell))
    1183     (let ((class (cdr class-cell)))
     1183  (unless (istruct-typep  class-cell 'class-cell)
     1184    (report-bad-arg class-cell 'class-cell))
     1185  (locally (declare (type class-cell  class-cell))
     1186    (let ((class (class-cell-class class-cell)))
    11841187      (when (not class)
    1185         (setq class (find-class (car class-cell) nil))
    1186         (when class (rplacd class-cell class)))
     1188        (setq class (find-class (class-cell-name class-cell) nil))
     1189        (when class (setf (class-cell-class class-cell) class)))
    11871190      (if class
    11881191        (not (null (memq class (%inited-class-cpl (class-of form)))))
    1189         (if (fboundp 'typep)(typep form (car class-cell)) t)))))
     1192        (if (fboundp 'typep)(typep form (class-cell-name class-cell)) t)))))
    11901193
    11911194
    11921195
    11931196(defun %require-type-class-cell (arg class-cell)
    1194   ; sort of weird 
    1195   (if (or ;(not *type-system-initialized*)
    1196           (not (listp class-cell)))  ; bootstrapping prob no longer
    1197     arg ; (progn (pushnew class-cell puke) arg)
    1198     (if (class-cell-typep arg class-cell)
    1199       arg
    1200       (%kernel-restart $xwrongtype arg (car class-cell)))))
     1197  (if (class-cell-typep arg class-cell)
     1198    arg
     1199    (%kernel-restart $xwrongtype arg (car class-cell))))
    12011200
    12021201
     
    12061205    (or cell
    12071206        (and create?
    1208              (setf (gethash name %find-classes%) (cons name nil))))))
     1207             (setf (gethash name %find-classes%) (make-class-cell name))))))
    12091208
    12101209
    12111210(defun find-class (name &optional (errorp t) environment)
    12121211  (let* ((cell (find-class-cell name nil)))
    1213     (declare (list cell))
    1214     (or (cdr cell)
     1212    (declare (type class-cell cell))
     1213    (or (and cell (class-cell-class cell))
    12151214        (let ((defenv (and environment (definition-environment environment))))
    12161215          (when defenv
     
    12271226      (if (eq name (%class.name class))
    12281227        (setf (info-type-kind name) :instance))
    1229       (setf (cdr (the cons cell)) class))
     1228      (setf (class-cell-class cell) class))
    12301229    class))
    12311230
     
    12661265   (setq name (require-type name 'symbol))
    12671266   (let ((cell (find-class-cell name class)))
    1268      (declare (type list cell))
    1269        (let ((old-class (cdr cell)))
     1267     (declare (type class-cell cell))
     1268       (let ((old-class (class-cell-class cell)))
    12701269         (when old-class
    12711270           (when (eq (%class.name old-class) name)
     
    12761275     (when (null class)
    12771276       (when cell
    1278          (setf (cdr cell) nil))
     1277         (setf (class-cell-class cell) nil))
    12791278       (return-from set-find-class nil))
    12801279     (setq class (require-type class 'class))
     
    12891288         (%deftype name nil nil))
    12901289       (setf (info-type-kind name) :instance))
    1291      (setf (cdr cell) class)))
     1290     (setf (class-cell-class cell) class)))
    12921291 )                                      ; end of queue-fixup
    12931292
     
    16831682  (make-built-in-class 'intersection-ctype *ctype-class*)
    16841683 
    1685 
     1684  (make-built-in-class 'class-cell *istruct-class*)
    16861685  (make-built-in-class 'complex (find-class 'number))
    16871686  (make-built-in-class 'real (find-class 'number))
     
    17821781
    17831782  (defun class-cell-find-class (class-cell errorp)
    1784     (unless (listp class-cell)
    1785       (setq class-cell (%kernel-restart $xwrongtype class-cell 'list)))
    1786     (locally (declare (type list class-cell))
    1787       (let ((class (cdr class-cell)))
     1783    (unless (istruct-typep class-cell 'class-cell)
     1784      (setq class-cell (%kernel-restart $xwrongtype class-cell 'class-cell)))
     1785    (locally (declare (type class-cell class-cell))
     1786      (let ((class (class-cell-class class-cell)))
    17881787        (or class
    17891788            (and
    1790              (setq class (find-class (car class-cell) nil))
     1789             (setq class (find-class (class-cell-name class-cell) nil))
    17911790             (when class
    1792                (rplacd class-cell class)
     1791               (setf (class-cell-class class-cell) class)
    17931792               class))
    1794             (if errorp (error "Class ~s not found." (car class-cell)) nil)))))
     1793            (if errorp (error "Class ~s not found." (class-cell-name class-cell)) nil)))))
    17951794
    17961795;;; (%wrapper-class (instance.class-wrapper frob))
     
    23962395  (declare (dynamic-extent initargs))
    23972396  (apply #'make-instance
    2398          (or (cdr class-cell) (car (the list class-cell)))
     2397         (or (class-cell-class class-cell) (class-cell-name  (the class-cell class-cell)))
    23992398         initargs))
    24002399
Note: See TracChangeset for help on using the changeset viewer.