Index: /branches/objc-gf/ccl/lib/macros.lisp
===================================================================
--- /branches/objc-gf/ccl/lib/macros.lisp	(revision 6045)
+++ /branches/objc-gf/ccl/lib/macros.lisp	(revision 6046)
@@ -2784,17 +2784,25 @@
   (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,10 +2833,10 @@
   (%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,8 +2846,21 @@
 	 (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)