Changeset 6188


Ignore:
Timestamp:
Apr 8, 2007, 3:55:30 AM (13 years ago)
Author:
gb
Message:

DEFSTATIC is now the preferred name for DEFGLOBAL.

Mechanism for associating a (built-in) class with a foreign type
ordinal.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/ccl/level-1/l1-clos-boot.lisp

    r6028 r6188  
    518518
    519519
    520 (defglobal *type-system-initialized* nil)
     520(defstatic *type-system-initialized* nil)
    521521
    522522(eval-when (eval compile)
     
    785785  (lfun-name method-function))
    786786
    787 (defglobal %defgeneric-methods% (make-hash-table :test 'eq :weak t))
     787(defstatic %defgeneric-methods% (make-hash-table :test 'eq :weak t))
    788788
    789789(defun %defgeneric-methods (gf)
     
    861861  gfn)
    862862
    863 (defglobal *standard-kernel-method-class* nil)
     863(defstatic *standard-kernel-method-class* nil)
    864864
    865865(defun redefine-kernel-method (method)
     
    13881388;;; the instance.class-wrapper of all the classes that STANDARD-CLASS
    13891389;;; inherits from.
    1390 (defglobal *standard-class-wrapper*
     1390(defstatic *standard-class-wrapper*
    13911391  (%cons-wrapper 'standard-class))
    13921392
     
    14671467  (memq *specializer-class* (%inited-class-cpl (class-of thing))))
    14681468
    1469 (defglobal *standard-object-class* (make-standard-class 'standard-object *t-class*))
    1470 
    1471 (defglobal *metaobject-class* (make-standard-class 'metaobject *standard-object-class*))
    1472 
    1473 (defglobal *specializer-class* (make-standard-class 'specializer *metaobject-class*))
    1474 (defglobal *eql-specializer-class* (make-standard-class 'eql-specializer *specializer-class*))
    1475 
    1476 (defglobal *standard-method-combination*
     1469(defstatic *standard-object-class* (make-standard-class 'standard-object *t-class*))
     1470
     1471(defstatic *metaobject-class* (make-standard-class 'metaobject *standard-object-class*))
     1472
     1473(defstatic *specializer-class* (make-standard-class 'specializer *metaobject-class*))
     1474(defstatic *eql-specializer-class* (make-standard-class 'eql-specializer *specializer-class*))
     1475
     1476(defstatic *standard-method-combination*
    14771477  (make-instance-vector
    14781478   (%class.own-wrapper
     
    14891489
    14901490;;; The *xxx-class-class* instances get slots near the end of this file.
    1491 (defglobal *class-class* (make-standard-class 'class *specializer-class*))
    1492 
    1493 (defglobal *slots-class* (make-standard-class 'slots-class *class-class*))
    1494 (defglobal *slots-class-wrapper* (%class.own-wrapper *slots-class*))
     1491(defstatic *class-class* (make-standard-class 'class *specializer-class*))
     1492
     1493(defstatic *slots-class* (make-standard-class 'slots-class *class-class*))
     1494(defstatic *slots-class-wrapper* (%class.own-wrapper *slots-class*))
    14951495
    14961496
     
    14991499;;; shared by anybody but their subclasses.
    15001500
    1501 (defglobal *std-class-class* (make-standard-class 'std-class *slots-class*))
     1501(defstatic *std-class-class* (make-standard-class 'std-class *slots-class*))
    15021502
    15031503;;; The class of all objects whose metaclass is standard-class. Yow.
    1504 (defglobal *standard-class-class* (make-standard-class 'standard-class *std-class-class*))
     1504(defstatic *standard-class-class* (make-standard-class 'standard-class *std-class-class*))
    15051505;;; Replace its wrapper and the circle is closed.
    15061506(setf (%class.own-wrapper *standard-class-class*) *standard-class-wrapper*
     
    15081508      (%wrapper-instance-slots *standard-class-wrapper*) (vector))
    15091509
    1510 (defglobal *built-in-class-class* (make-standard-class 'built-in-class *class-class*))
     1510(defstatic *built-in-class-class* (make-standard-class 'built-in-class *class-class*))
    15111511(setf *built-in-class-wrapper* (%class.own-wrapper *built-in-class-class*)
    15121512      (instance.class-wrapper *t-class*) *built-in-class-wrapper*)
    15131513
    1514 (defglobal *structure-class-class* (make-standard-class 'structure-class *slots-class*))
    1515 (defglobal *structure-class-wrapper* (%class.own-wrapper *structure-class-class*))
    1516 (defglobal *structure-object-class*
     1514(defstatic *structure-class-class* (make-standard-class 'structure-class *slots-class*))
     1515(defstatic *structure-class-wrapper* (%class.own-wrapper *structure-class-class*))
     1516(defstatic *structure-object-class*
    15171517  (make-class 'structure-object *structure-class-wrapper* (list *t-class*)))
    15181518
    1519 (defglobal *forward-referenced-class-class*
     1519(defstatic *forward-referenced-class-class*
    15201520  (make-standard-class 'forward-referenced-class *class-class*))
    15211521
    1522 (defglobal *function-class* (make-built-in-class 'function))
     1522(defstatic *function-class* (make-built-in-class 'function))
    15231523
    15241524(defun alias-class (name class)
     
    15301530
    15311531
    1532 (defglobal *compiled-function-class* *function-class*)
     1532(defstatic *compiled-function-class* *function-class*)
    15331533(alias-class 'compiled-function *compiled-function-class*)
    15341534
    1535 (defglobal *compiled-lexical-closure-class*
     1535(defstatic *compiled-lexical-closure-class*
    15361536  (make-standard-class 'compiled-lexical-closure *function-class*))
    15371537
     
    15401540
    15411541
    1542 (defglobal *funcallable-standard-class-class*
     1542(defstatic *funcallable-standard-class-class*
    15431543  (make-standard-class 'funcallable-standard-class *std-class-class*))
    15441544
    1545 (defglobal *funcallable-standard-object-class*
     1545(defstatic *funcallable-standard-object-class*
    15461546  (make-class 'funcallable-standard-object
    15471547              (%class.own-wrapper *funcallable-standard-class-class*)
    15481548              (list *standard-object-class* *function-class*)))
    15491549
    1550 (defglobal *generic-function-class*
     1550(defstatic *generic-function-class*
    15511551  (make-class 'generic-function
    15521552              (%class.own-wrapper *funcallable-standard-class-class*)
     
    15541554(setq *generic-function-class-wrapper* (%class.own-wrapper *generic-function-class*))
    15551555
    1556 (defglobal *standard-generic-function-class*
     1556(defstatic *standard-generic-function-class*
    15571557  (make-class 'standard-generic-function
    15581558              (%class.own-wrapper *funcallable-standard-class-class*)
     
    15621562
    15631563;;; *standard-method-class* is upgraded to a real class below
    1564 (defglobal *method-class* (make-standard-class 'method *metaobject-class*))
    1565 (defglobal *standard-method-class* (make-standard-class 'standard-method *method-class*))
    1566 (defglobal *accessor-method-class* (make-standard-class 'standard-accessor-method *standard-method-class*))
    1567 (defglobal *standard-reader-method-class* (make-standard-class 'standard-reader-method *accessor-method-class*))
    1568 (defglobal *standard-writer-method-class* (make-standard-class 'standard-writer-method *accessor-method-class*))
    1569 (defglobal *method-function-class* (make-standard-class 'method-function *function-class*))
    1570 
    1571 
    1572 (defglobal *combined-method-class* (make-standard-class 'combined-method *function-class*))
    1573 
    1574 (defglobal *slot-definition-class* (make-standard-class 'slot-definition *metaobject-class*))
    1575 (defglobal direct-slot-definition-class (make-standard-class 'direct-slot-definition
     1564(defstatic *method-class* (make-standard-class 'method *metaobject-class*))
     1565(defstatic *standard-method-class* (make-standard-class 'standard-method *method-class*))
     1566(defstatic *accessor-method-class* (make-standard-class 'standard-accessor-method *standard-method-class*))
     1567(defstatic *standard-reader-method-class* (make-standard-class 'standard-reader-method *accessor-method-class*))
     1568(defstatic *standard-writer-method-class* (make-standard-class 'standard-writer-method *accessor-method-class*))
     1569(defstatic *method-function-class* (make-standard-class 'method-function *function-class*))
     1570
     1571
     1572(defstatic *combined-method-class* (make-standard-class 'combined-method *function-class*))
     1573
     1574(defstatic *slot-definition-class* (make-standard-class 'slot-definition *metaobject-class*))
     1575(defstatic direct-slot-definition-class (make-standard-class 'direct-slot-definition
    15761576                                                           *slot-definition-class*))
    1577 (defglobal effective-slot-definition-class (make-standard-class 'effective-slot-definition
     1577(defstatic effective-slot-definition-class (make-standard-class 'effective-slot-definition
    15781578                                                              *slot-definition-class*))
    1579 (defglobal *standard-slot-definition-class* (make-standard-class 'standard-slot-definition
     1579(defstatic *standard-slot-definition-class* (make-standard-class 'standard-slot-definition
    15801580                                                              *slot-definition-class*))
    1581 (defglobal *standard-direct-slot-definition-class* (make-class
     1581(defstatic *standard-direct-slot-definition-class* (make-class
    15821582                                                 'standard-direct-slot-definition
    15831583                                                 *standard-class-wrapper*
     
    15861586                                                  direct-slot-definition-class)))
    15871587
    1588 (defglobal *standard-effective-slot-definition-class* (make-class
     1588(defstatic *standard-effective-slot-definition-class* (make-class
    15891589                                                    'standard-effective-slot-definition
    15901590                                                    *standard-class-wrapper*
     
    15941594))
    15951595
    1596 (defglobal *standard-effective-slot-definition-class-wrapper*
     1596(defstatic *standard-effective-slot-definition-class-wrapper*
    15971597  (%class.own-wrapper *standard-effective-slot-definition-class*))
    15981598
    15991599
    16001600
    1601 (let ((*dont-find-class-optimize* t))
     1601
     1602(let ((*dont-find-class-optimize* t)
     1603      (ordinal-type-class-alist ())
     1604      (ordinal-type-class-alist-lock (make-lock)))
    16021605
    16031606;; The built-in classes.
    1604   (defglobal *array-class* (make-built-in-class 'array))
    1605   (defglobal *character-class* (make-built-in-class 'character))
     1607  (defstatic *array-class* (make-built-in-class 'array))
     1608  (defstatic *character-class* (make-built-in-class 'character))
    16061609  (make-built-in-class 'number)
    16071610  (make-built-in-class 'sequence)
    1608   (defglobal *symbol-class* (make-built-in-class 'symbol))
    1609   (defglobal *immediate-class* (make-built-in-class 'immediate)) ; Random immediate
     1611  (defstatic *symbol-class* (make-built-in-class 'symbol))
     1612  (defstatic *immediate-class* (make-built-in-class 'immediate)) ; Random immediate
    16101613  ;; Random uvectors - these are NOT class of all things represented by a uvector
    16111614  ;;type. Just random uvectors which don't fit anywhere else.
    16121615  (make-built-in-class 'ivector)        ; unknown ivector
    16131616  (make-built-in-class 'gvector)        ; unknown gvector
    1614   (defglobal *istruct-class* (make-built-in-class 'internal-structure)) ; unknown istruct
     1617  (defstatic *istruct-class* (make-built-in-class 'internal-structure)) ; unknown istruct
    16151618 
    1616   (defglobal *slot-vector-class* (make-built-in-class 'slot-vector (find-class 'gvector)))
     1619  (defstatic *slot-vector-class* (make-built-in-class 'slot-vector (find-class 'gvector)))
    16171620 
    1618   (defglobal *macptr-class* (make-built-in-class 'macptr))
    1619   (defglobal *foreign-standard-object-class*
     1621  (defstatic *macptr-class* (make-built-in-class 'macptr))
     1622  (defstatic *foreign-standard-object-class*
    16201623    (make-standard-class 'foreign-standard-object
    16211624                         *standard-object-class* *macptr-class*))
    16221625
    1623   (defglobal *foreign-class-class*
     1626  (defstatic *foreign-class-class*
    16241627    (make-standard-class 'foreign-class *foreign-standard-object-class* *slots-class*))
    16251628 
     
    16271630  (make-built-in-class 'pool)
    16281631  (make-built-in-class 'package)
    1629   (defglobal *lock-class* (make-built-in-class 'lock))
    1630   (defglobal *recursive-lock-class* (make-built-in-class 'recursive-lock *lock-class*))
    1631   (defglobal *read-write-lock-class* (make-built-in-class 'read-write-lock *lock-class*))
     1632  (defstatic *lock-class* (make-built-in-class 'lock))
     1633  (defstatic *recursive-lock-class* (make-built-in-class 'recursive-lock *lock-class*))
     1634  (defstatic *read-write-lock-class* (make-built-in-class 'read-write-lock *lock-class*))
    16321635 
    16331636  (make-built-in-class 'lock-acquisition *istruct-class*)
     
    16621665  (make-built-in-class 'type-class *istruct-class*)
    16631666 
    1664   (defglobal *ctype-class* (make-built-in-class 'ctype *istruct-class*))
     1667  (defstatic *ctype-class* (make-built-in-class 'ctype *istruct-class*))
    16651668  (make-built-in-class 'key-info *istruct-class*)
    1666   (defglobal *args-ctype* (make-built-in-class 'args-ctype *ctype-class*))
     1669  (defstatic *args-ctype* (make-built-in-class 'args-ctype *ctype-class*))
    16671670  (make-built-in-class 'values-ctype *args-ctype*)
    16681671  (make-built-in-class 'function-ctype *args-ctype*)
     
    16831686  (make-built-in-class 'complex (find-class 'number))
    16841687  (make-built-in-class 'real (find-class 'number))
    1685   (defglobal *float-class* (make-built-in-class 'float (find-class 'real)))
    1686   (defglobal *double-float-class* (make-built-in-class 'double-float (find-class 'float)))
    1687   (defglobal *single-float-class*  (make-built-in-class 'single-float (find-class 'float)))
     1688  (defstatic *float-class* (make-built-in-class 'float (find-class 'real)))
     1689  (defstatic *double-float-class* (make-built-in-class 'double-float (find-class 'float)))
     1690  (defstatic *single-float-class*  (make-built-in-class 'single-float (find-class 'float)))
    16881691  (alias-class 'short-float *single-float-class*)
    16891692  (alias-class 'long-float *double-float-class*)
     
    16921695  (make-built-in-class 'ratio (find-class 'rational))
    16931696  (make-built-in-class 'integer (find-class 'rational))
    1694   (defglobal *fixnum-class* (make-built-in-class 'fixnum (find-class 'integer)))
     1697  (defstatic *fixnum-class* (make-built-in-class 'fixnum (find-class 'integer)))
    16951698
    16961699  #+x8664-target
    1697   (defglobal *tagged-return-address-class* (make-built-in-class 'tagged-return-address))
     1700  (defstatic *tagged-return-address-class* (make-built-in-class 'tagged-return-address))
    16981701  (make-built-in-class 'bignum (find-class 'integer))
    16991702 
     
    17051708  (make-built-in-class 'logical-pathname (find-class 'pathname))
    17061709 
    1707   (defglobal *base-char-class* (alias-class 'base-char *character-class*))
    1708   (defglobal *standard-char-class* (make-built-in-class 'standard-char *base-char-class*))
     1710  (defstatic *base-char-class* (alias-class 'base-char *character-class*))
     1711  (defstatic *standard-char-class* (make-built-in-class 'standard-char *base-char-class*))
    17091712 
    1710   (defglobal *keyword-class* (make-built-in-class 'keyword *symbol-class*))
     1713  (defstatic *keyword-class* (make-built-in-class 'keyword *symbol-class*))
    17111714 
    17121715  (make-built-in-class 'list (find-class 'sequence))
    1713   (defglobal *cons-class* (make-built-in-class 'cons (find-class 'list)))
    1714   (defglobal *null-class* (make-built-in-class 'null *symbol-class* (find-class 'list)))
     1716  (defstatic *cons-class* (make-built-in-class 'cons (find-class 'list)))
     1717  (defstatic *null-class* (make-built-in-class 'null *symbol-class* (find-class 'list)))
    17151718 
    1716   (defglobal *vector-class* (make-built-in-class 'vector *array-class* (find-class 'sequence)))
    1717   (defglobal *simple-array-class* (make-built-in-class 'simple-array *array-class*))
     1719  (defstatic *vector-class* (make-built-in-class 'vector *array-class* (find-class 'sequence)))
     1720  (defstatic *simple-array-class* (make-built-in-class 'simple-array *array-class*))
    17181721  (make-built-in-class 'simple-1d-array *vector-class* *simple-array-class*)
    17191722 
     
    17951798
    17961799
    1797   (defglobal *general-vector-class* (find-class 'general-vector))
     1800  (defstatic *general-vector-class* (find-class 'general-vector))
    17981801
    17991802  #+ppc32-target
     
    19771980        x))
    19781981
     1982  (defun %register-type-ordinal-class (foreign-type class-name)
     1983    ;; ordinal-type-class shouldn't already exist
     1984    (with-lock-grabbed (ordinal-type-class-alist-lock)
     1985      (or (let* ((class (cdr (assq foreign-type ordinal-type-class-alist))))
     1986            (if (and class (eq class-name (class-name class)))
     1987              class))
     1988          (let* ((class (make-built-in-class class-name 'macptr)))
     1989            (push (cons foreign-type class) ordinal-type-class-alist)
     1990            class))))
     1991
     1992  (defun %ordinal-type-class-for-macptr (p)
     1993    (with-lock-grabbed (ordinal-type-class-alist-lock)
     1994      (or (cdr (assoc (%macptr-type p) ordinal-type-class-alist :key #'foreign-type-ordinal))
     1995          *macptr-class*)))
     1996                 
     1997
    19791998  (register-foreign-object-domain :unclassified
    19801999                                  :recognize #'(lambda (p)
     
    20062025  (register-foreign-object-domain :raw
    20072026                                  :recognize #'true
    2008                                   :class-of (constantly *macptr-class*)
     2027                                  :class-of #'%ordinal-type-class-for-macptr
    20092028                                  :classp #'false
    20102029                                  :instance-class-wrapper
    2011                                   (constantly (%class.own-wrapper *macptr-class*))
     2030                                  (lambda (p)
     2031                                    (%class.own-wrapper (%ordinal-type-class-for-macptr p)))
    20122032                                  :class-own-wrapper #'false
    20132033                                  :slots-vector #'false)
    20142034
    2015   (defglobal *class-table*
     2035  (defstatic *class-table*
    20162036      (let* ((v (make-array 256 :initial-element nil))
    20172037             (class-of-function-function
     
    31503170
    31513171
    3152 (defglobal *initialization-function-lists*
     3172(defstatic *initialization-function-lists*
    31533173  (list (list #'initialize-instance #'allocate-instance #'shared-initialize)
    31543174        (list #'reinitialize-instance #'shared-initialize)
Note: See TracChangeset for help on using the changeset viewer.