Ignore:
Timestamp:
Aug 9, 2008, 2:39:01 AM (11 years ago)
Author:
gb
Message:

Move %FIND-CLASSES% and accessor to level-0.

Start to bootstrap structure-type changes by making STRUCTURE-TYPEP
handle legacy/new cases.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/level-0/l0-pred.lisp

    r10351 r10406  
    2626  (cons type nil))
    2727
    28 (defun find-class-cell (type create?)
    29   (declare (ignore create?))
    30   (make-class-cell type))
    3128
    3229(defun builtin-typep (form cell)
     
    1002999  (= (the fixnum (typecode form)) target::subtag-istruct))
    10031000
     1001
     1002;;; Not to be conused with STRUCTURE-TYPE-P, defined in ccl:lib;pprint.lisp.
     1003;;; (If you've ever been "conused", I'm sure you know just how painful
     1004;;; that can be.)
     1005
     1006;;; In the short term (bootstrapping), expect TYPE to be a a SYMBOL.
     1007;;; If THING is a structure instance (has typecode subtag-struct),
     1008;;; its 0th element is either a list of symbols (traditional, legacy
     1009;;; case) or a list of CLASS-CELLs.
    10041010(defun structure-typep (thing type)
    10051011  (if (= (the fixnum (typecode thing)) target::subtag-struct)
    1006     (if (memq type (%svref thing 0))
    1007       t)))
     1012    (dolist (i (%svref thing 0))
     1013      (if (or (eq i type)
     1014              (and (not (symbolp i))
     1015                   (eq (class-cell-name i) type)))
     1016        (return t)))))
     1017
    10081018
    10091019
     
    10641074(defun listp (x)
    10651075  (listp x))
     1076
     1077(defparameter *type-cells* nil)
     1078
     1079
     1080
     1081(defparameter *type-cells-lock* nil)
     1082
     1083
     1084;;; The weird handling to the special variables here has to do with
     1085;;; xload issues.
     1086(defun register-type-cell (specifier)
     1087  (with-lock-grabbed ((or *type-cells-lock*
     1088                         (setq *type-cells-lock* (make-lock))))
     1089    (unless *type-cells*
     1090      (setq *type-cells* (make-hash-table :test 'equal)))
     1091    (or (values (gethash specifier *type-cells*))
     1092        (setf (gethash specifier *type-cells*)
     1093              (make-type-cell specifier)))))
     1094
     1095
     1096(defvar %find-classes% nil)
     1097
     1098(setq %find-classes% (make-hash-table :test 'eq))
     1099
     1100
     1101(defun find-class-cell (name create?)
     1102  (unless %find-classes%
     1103    (dbg name))
     1104  (let ((cell (gethash name %find-classes%)))
     1105    (or cell
     1106        (and create?
     1107             (setf (gethash name %find-classes%) (make-class-cell name))))))
     1108
Note: See TracChangeset for help on using the changeset viewer.