r2784: *** empty log message ***

[uffi.git] / src-mcl / objects.cl

diff --git a/src-mcl/objects.cl b/src-mcl/objects.cl
index c339b4d31940ea07577437aa6780baff9b143214..82adf1651791337073b3838eb051ed410b2eab6f 100644 (file)
--- a/src-mcl/objects.cl
+++ b/src-mcl/objects.cl
@@ -7,7 +7,7 @@
 ;;;; Programmers:   Kevin M. Rosenberg and John DeSoi
 ;;;; Date Started:  Feb 2002
 ;;;;
-;;;; $Id: objects.cl,v 1.1 2002/09/16 17:57:43 kevin Exp $
+;;;; $Id: objects.cl,v 1.2 2002/09/20 04:51:14 kevin Exp $
 ;;;;
 ;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
 ;;;; and John DeSoi
@@ -24,34 +24,49 @@
 ;;;
 ;;; Some MCL specific utilities
 ;;;
-(defun foreign-object-size (type)
-  "Returns the size for the specified mcl type or record type"
-  (let ((mcl-type (ccl:find-mactype type nil t)))
-    (if mcl-type 
-      (ccl::mactype-record-size mcl-type)
-      (ccl::record-descriptor-length (ccl:find-record-descriptor type t t)) ) ) ) ;error if not a record
-
 
-; trap macros don't work right directly in the macros  
+; trap macros don't work right directly in the macros
 (eval-when (:compile-toplevel :load-toplevel :execute)
 
+#-openmcl  
 (defun new-ptr (size)
   (#_NewPtr size))
 
+#-openmcl
 (defun dispose-ptr (ptr)
   (#_DisposePtr ptr))
 
+#+openmcl
+(defmacro new-ptr (size)
+  `(ccl::malloc ,size))
+
+#+openmcl
+(defmacro dispose-ptr (ptr)
+  `(ccl::free ,ptr))
+
 )
 
 ;;;
 ;;; Start of standard UFFI
 ;;;
+(defun size-of-foreign-type (type)
+  "Returns the size for the specified mcl type or record type"
+  #+openmcl
+  (ccl::%foreign-type-or-record-size type :bytes)
+  #-openmcl
+  (let ((mcl-type (ccl:find-mactype type nil t)))
+    (if mcl-type 
+      (ccl::mactype-record-size mcl-type)
+      (ccl::record-descriptor-length (ccl:find-record-descriptor type t t)) ) ) ) ;error if not a record
+
+
+
 (defmacro allocate-foreign-object (type &optional (size :unspecified))
   "Allocates an instance of TYPE. If size is specified, then allocate
 an array of TYPE with size SIZE."
   (if (eq size :unspecified)
-    `(new-ptr ,(foreign-object-size (convert-from-uffi-type type :allocation)))
-    `(new-ptr ,(* size (foreign-object-size (convert-from-uffi-type type :allocation))))))
+    `(new-ptr ,(size-of-foreign-type (convert-from-uffi-type type :allocation)))
+    `(new-ptr (* ,size ,(size-of-foreign-type (convert-from-uffi-type type :allocation))))))
 
 
 
@@ -67,47 +82,49 @@ an array of TYPE with size SIZE."
   `(ccl:%null-ptr))
 
 
-;! need to check uffi update and see if :routine is the right context
+;already a macptr
+(defmacro char-array-to-pointer (obj)
+  obj)
 
-(defun accessor-symbol (type get-or-set)
-  "Returns the symbol used to access the foreign type."
-  (let* ((mcl-type (convert-from-uffi-type (eval type) :routine))
-         (mac-type (ccl:find-mactype mcl-type))
-         name)
-    (ecase get-or-set
-      (:get (setf name (ccl::mactype-get-function mac-type)))
-      (:set (setf name (ccl::mactype-set-function mac-type))))
-    (find-symbol (symbol-name name) :ccl)))
 
 (defmacro deref-pointer (ptr type)
-  `(,(accessor-symbol type :get) ,ptr))
-
+  `(ccl:pref ,ptr ,(convert-from-uffi-type type :deref)))
 
 (defmacro deref-pointer-set (ptr type value)
-  `(,(accessor-symbol type :set) ,ptr ,value))
-
+  `(setf (ccl:pref ,ptr ,(convert-from-uffi-type type :deref)) ,value))
 
 (defsetf deref-pointer deref-pointer-set)
 
 
+(defmacro ensure-char-character (obj)
+  #-openmcl obj
+  #+openmcl `(code-char ,obj))
+
+
+(defmacro ensure-char-integer (obj)
+  #-openmcl `(char-code ,obj)
+  #+openmcl obj)
+
+
 (defmacro pointer-address (obj)
   `(ccl:%ptr-to-int ,obj))
 
 
+
 (defmacro with-foreign-objects (bindings &rest body)
-  (let ((simple nil) (recs nil) type)
+  (let ((params nil) type count)
     (dolist (spec (reverse bindings)) ;keep order - macroexpands to let*
       (setf type (convert-from-uffi-type (eval (nth 1 spec)) :allocate))
-      (if (ccl:mactype-p type)
-        (push (list (first spec) (foreign-object-size type)) simple)
-        (push spec recs)))
-    (cond ((and simple recs)
-           `(ccl:%stack-block ,simple
-              (ccl:rlet ,recs
-                ,@body)))
-          (simple `(ccl:%stack-block ,simple ,@body))
-          (recs `(ccl:rlet ,recs ,@body)))))
+      (setf count 1)
+      (when (and (listp type) (eq (first type) :array))
+        (setf count (nth 2 type))
+        (unless (integerp count) (error "Invalid size for array: ~a" type))
+        (setf type (nth 1 type)))
+      (push (list (first spec) (* count (size-of-foreign-type type))) params))
+    `(ccl:%stack-block ,params ,@body)))
 
 
 (defmacro with-foreign-object ((var type) &rest body)
-  `(with-foreign-objects ((,var ,type)) ,@body))
+  `(with-foreign-objects ((,var ,type)) 
+     ,@body))
+