Changeset 403

Timestamp:

Jan 25, 2004, 2:14:24 PM (21 years ago)

Author:

Gary Byers

Message:

Try to introduce "foreign type ordinals", which can be embedded in
MACPTRs (this is hard to bootstrap for many reasons.)
(PREF foo :thing.embedded-record) expands into some SETFable noise
around %INC-PTR.

File:

• trunk/ccl/lib/foreign-types.lisp (modified) (7 diffs)

trunk/ccl/lib/foreign-types.lisp

@@ -58 +58 @@
   (attributes #+darwinppc-target '(:signed-char :struct-by-value :prepend-underscores)
               #+linuxppc-target ())
-  (ordinal->type (make-array 100 :fill-pointer 0)))
+  (ordinal->type (make-array 100 :fill-pointer 1)))
 
 (defvar *host-ftd* (make-ftd))
@@ -288 +288 @@
   (class 'root :type symbol)
   (bits nil :type (or null unsigned-byte))
-  (alignment (guess-alignment bits) :type (or null unsigned-byte)))
+  (alignment (guess-alignment bits) :type (or null unsigned-byte))
+  (assigned-ordinal nil))
+
+(defun foreign-type-ordinal (ftype)
+  (or (foreign-type-assigned-ordinal ftype)
+      (setf (foreign-type-assigned-ordinal ftype)
+            (vector-push-extend ftype (ftd-ordinal->type *target-ftd*)))))
+
+(defun ordinal-to-foreign-type (ordinal &optional (ftd *target-ftd*))
+  (elt (ftd-ordinal->type ftd) ordinal))
+
 
 (defmethod make-load-form ((s foreign-type) &optional env)
   (make-load-form-saving-slots s :environment env))
+
 
 
@@ -623 +634 @@
     (make-foreign-integer-type :bits bits)))
 
+
+
 (def-foreign-type-translator integer (&optional (bits 32))
   (if (<= bits 32)
@@ -634 +647 @@
 
 (def-foreign-type-method (integer :unparse) (type)
-  (list (if (foreign-integer-type-signed type) 'signed 'unsigned)
+  (list (if (foreign-integer-type-signed type) :signed :unsigned)
         (foreign-integer-type-bits type)))
 
@@ -855 +868 @@
 ;;;; The MEM-BLOCK type.
 
+
 (def-foreign-type-class (mem-block :include foreign-value))
 
 (def-foreign-type-method (mem-block :extract-gen) (type sap offset)
-  (declare (ignore type))
-  `(%inc-ptr ,sap (/ ,offset 8)))
+  (let* ((nbytes (%foreign-type-or-record-size type :bytes)))
+    `(%composite-pointer-ref ,nbytes ,sap (/ ,offset 8))))
 
 (def-foreign-type-method (mem-block :deposit-gen) (type sap offset value)
@@ -1298 +1312 @@
 
 (defun %foreign-type-or-record (type)
-  (if (consp type)
-    (parse-foreign-type type)
-    (or (%find-foreign-record type)
-        (parse-foreign-type type))))
+  (if (typep type 'foreign-type)
+    type
+    (if (consp type)
+      (parse-foreign-type type)
+      (or (%find-foreign-record type)
+          (parse-foreign-type type)))))
 
 (defun %foreign-type-or-record-size (type &optional (units :bits))
@@ -1617 +1633 @@
             (accessors s))
           (accessors field-name))))))
+
+(defun %assert-macptr-ftype (macptr ftype)
+  (if (eq (class-of macptr) *macptr-class*)
+    (%set-macptr-type macptr (foreign-type-ordinal ftype)))
+  macptr)
+
+(defun %macptr-ftype (macptr)
+  (if (eq (class-of macptr) *macptr-class*)
+    (ordinal-to-foreign-type (%macptr-type macptr))))
+
+
   
+