Changeset 6055 for branches

Timestamp:

Mar 17, 2007, 6:32:24 PM (18 years ago)

Author:

Gary Byers

Message:

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

File:

• branches/objc-gf/ccl/level-1/l1-clos-boot.lisp (modified) (3 diffs)

branches/objc-gf/ccl/level-1/l1-clos-boot.lisp

@@ -1599 +1599 @@
 
 
-(let ((*dont-find-class-optimize* t))
+
+(let ((*dont-find-class-optimize* t)
+      (ordinal-type-class-alist ())
+      (ordinal-type-class-alist-lock (make-lock)))
 
 ;; The built-in classes.
@@ -1977 +1980 @@
         x))
 
+  (defun %register-type-ordinal-class (foreign-type class-name)
+    ;; ordinal-type-class shouldn't already exist
+    (with-lock-grabbed (ordinal-type-class-alist-lock)
+      (or (let* ((class (cdr (assq foreign-type ordinal-type-class-alist))))
+            (if (and class (eq class-name (class-name class)))
+              class))
+          (let* ((class (make-built-in-class class-name 'macptr)))
+            (push (cons foreign-type class) ordinal-type-class-alist)
+            class))))
+
+  (defun %ordinal-type-class-for-macptr (p)
+    (with-lock-grabbed (ordinal-type-class-alist-lock)
+      (or (cdr (assoc (%macptr-type p) ordinal-type-class-alist :key #'foreign-type-ordinal))
+          *macptr-class*)))
+                  
+
   (register-foreign-object-domain :unclassified
                                   :recognize #'(lambda (p)
@@ -2006 +2025 @@
   (register-foreign-object-domain :raw
                                   :recognize #'true
-                                  :class-of (constantly *macptr-class*)
+                                  :class-of #'%ordinal-type-class-for-macptr
                                   :classp #'false
                                   :instance-class-wrapper
-                                  (constantly (%class.own-wrapper *macptr-class*))
+                                  (lambda (p)
+                                    (%class.own-wrapper (%ordinal-type-class-for-macptr p)))
                                   :class-own-wrapper #'false
                                   :slots-vector #'false)