Changeset 6055


Ignore:
Timestamp:
Mar 18, 2007, 1:32:24 AM (13 years ago)
Author:
gb
Message:

Sketch out a mechanism for recognizing typed pointers as instances
of built-in classes.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • branches/objc-gf/ccl/level-1/l1-clos-boot.lisp

    r6028 r6055  
    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.
     
    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)
Note: See TracChangeset for help on using the changeset viewer.