Changeset 6046 for branches

Timestamp:

Mar 15, 2007, 4:29:23 AM (18 years ago)

Author:

Gary Byers

Message:

RLET, MAKE-RECORD assert pointer's type-ordinal.

File:

• branches/objc-gf/ccl/lib/macros.lisp (modified) (3 diffs)

branches/objc-gf/ccl/lib/macros.lisp

@@ -2784 +2784 @@
   (dolist (item inits result)
     (let* ((name (car item))
-           (record-name (cadr item))
-           (inits (cddr item))
-           (ftype (%foreign-type-or-record record-name)))
+           (record-name (cadr item))
+           (inits (cddr item))
+           (ftype (%foreign-type-or-record record-name))
+           (ordinal (foreign-type-ordinal ftype))
+           (ordinal-form (if (< ordinal max-canonical-foreign-type-ordinal)
+                           ordinal
+                           (progn
+                             (warn "Non canonical foreign-type-ordinal in ~s"
+                                   (unparse-foreign-type ftype))
+                             `(foreign-type-ordinal (load-time-value (%foreign-type-or-record ',record-name)))))))
+      (setq result (nconc result `((%set-macptr-type ,name ,ordinal-form))))
       (if (typep ftype 'foreign-record-type)
-        (setq result (nconc result (%foreign-record-field-forms name ftype record-name inits)))
-        (progn
-          ;(setq result (nconc result `((%assert-macptr-ftype ,name ,ftype))))
-          (when inits
-            (if (and ftype (null (cdr inits)))
+        (setq result
+              (nconc result (%foreign-record-field-forms name ftype record-name inits)))
+        (progn
+          (when inits
+            (if (and ftype (null (cdr inits)))
               (setq result
                     (nconc result
                            `((setf ,(%foreign-access-form name ftype 0 nil)
-                              ,(car inits)))))
+                              ,(car inits)))))
               (error "Unexpected or malformed initialization forms: ~s in field type: ~s"
                      inits record-name))))))))
@@ -2825 +2833 @@
   (%foreign-type-or-record-size recname :bytes))
 
-(defmacro make-record (record-name &rest initforms)
-  "Expand into code which allocates and initalizes an instance of the type
-denoted by typespec, on the foreign heap. The record is allocated using the
-C function malloc, and the user of make-record must explicitly call the C
-function free to deallocate the record, when it is no longer needed."
+(defun make-record-form (record-name allocator &rest initforms)
   (let* ((ftype (%foreign-type-or-record record-name))
+         (ordinal (foreign-type-ordinal ftype))
+         (ordinal-form (if (< ordinal max-canonical-foreign-type-ordinal)
+                         ordinal
+                         `(foreign-type-ordinal (load-time-value (%foreign-type-or-record ',record-name)))))
          (bits (ensure-foreign-type-bits ftype))
          (bytes (if bits
@@ -2838 +2846 @@
          (p (gensym))
          (bzero (read-from-string "#_bzero")))    
-    `(let* ((,p (malloc ,bytes)))
+    `(let* ((,p (,allocator ,bytes)))
+      (%set-macptr-type ,p ,ordinal-form)
       (,bzero ,p ,bytes)
       ,@(%foreign-record-field-forms p ftype record-name initforms)
       ,p)))
+  
+(defmacro make-record (record-name &rest initforms)
+  "Expand into code which allocates and initalizes an instance of the type
+denoted by typespec, on the foreign heap. The record is allocated using the
+C function malloc, and the user of make-record must explicitly call the C
+function free to deallocate the record, when it is no longer needed."
+  (apply 'make-record-form record-name 'malloc initforms))
+
+(defmacro make-gcable-record (record-name &rest initforms)
+  "Like MAKE-RECORD, only advises the GC that the foreign memory can
+   be deallocated if the returned pointer becomes garbage."
+  (apply 'make-record-form record-name '%new-gcable-ptr initforms))
 
 (defmacro with-terminal-input (&body body)