X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=src%2Fobjects.lisp;h=0e2d908f45fe9edea2b6709e2f4ed28a1a455c02;hb=7b35c93f34d7fbab2e7d487b42be5b1cb1aaa73a;hp=dc382f52627ff41022aa43ce34a15bcfd030dd44;hpb=ebedde4e67b858b1f65c5eb4dc7bc45978ed1e40;p=uffi.git

diff --git a/src/objects.lisp b/src/objects.lisp
index dc382f5..0e2d908 100644
--- a/src/objects.lisp
+++ b/src/objects.lisp
@@ -92,6 +92,16 @@ an array of TYPE with size SIZE. The TYPE parameter is evaluated."
   #+mcl `(ccl:%null-ptr)
   )
 
+(defmacro make-pointer (addr type)
+  #+(or allegro mcl) (declare (ignore type))
+  #+(or cmu scl) `(alien:sap-alien (system:int-sap ,addr) (* ,(convert-from-uffi-type (eval type) :type)))
+  #+sbcl `(sb-alien:sap-alien (sb-sys:int-sap ,addr) (* ,(convert-from-uffi-type (eval type) :type)))
+  #+lispworks `(fli:make-pointer :address ,addr :type (quote ,(convert-from-uffi-type (eval type) :type)))
+  #+allegro addr
+  #+mcl `(ccl:%int-to-ptr ,addr)
+  )
+
+
 (defmacro char-array-to-pointer (obj)
   #+(or cmu scl) `(alien:cast ,obj (* (alien:unsigned 8)))
   #+sbcl `(sb-alien:cast ,obj (* (sb-alien:unsigned 8)))
@@ -111,32 +121,28 @@ an array of TYPE with size SIZE. The TYPE parameter is evaluated."
   #+mcl `(ccl:pref ,ptr ,(convert-from-uffi-type type :deref))
   )
 
-#+mcl
+#+(and mcl (not openmcl))
 (defmacro deref-pointer-set (ptr type value)
   `(setf (ccl:pref ,ptr ,(convert-from-uffi-type type :deref)) ,value))
 
-#+mcl
+#+(and mcl (not openmcl))
 (defsetf deref-pointer deref-pointer-set)
 
-#+lispworks
 (defmacro ensure-char-character (obj)
+  #+(or (and mcl (not openmcl))) obj
+  #+(or allegro cmu sbcl scl openmcl) `(code-char ,obj)
+  ;; lispworks varies whether deref'ing array vs. slot access of a char
+  #+lispworks
   `(if (characterp ,obj) ,obj (code-char ,obj)))
-
-#+(and mcl (not openmcl)) 
-(defmacro ensure-char-character (obj)
-  obj)
-
-#+(or allegro cmu sbcl scl openmcl)
-(defmacro ensure-char-character (obj)
-  `(code-char ,obj))
   
-#+(or lispworks (and mcl (not openmcl)))
 (defmacro ensure-char-integer (obj)
- `(char-code ,obj))
+  #+(or (and mcl (not openmcl))) `(char-code ,obj)
+  #+(or allegro cmu sbcl scl openmcl) obj
+  `(if (characterp ,obj) (char-code ,obj) ,obj))
 
-#+(or allegro cmu sbcl scl openmcl)
-(defmacro ensure-char-integer (obj)
-  obj)
+(defmacro ensure-char-storable (obj)
+  #+(or lispworks (and mcl (not openmcl))) obj
+  #+(or allegro cmu sbcl scl openmcl) `(char-code ,obj))
 
 (defmacro pointer-address (obj)
   #+(or cmu scl)
@@ -160,15 +166,25 @@ an array of TYPE with size SIZE. The TYPE parameter is evaluated."
 	 (progn ,@body)
       (free-foreign-object ,var)))
   #+(or cmu scl)
-  (let ((obj (gensym)))
-    `(alien:with-alien ((,obj ,(convert-from-uffi-type (eval type) :allocate)))
-       (let ((,var (alien:addr ,obj)))
-	 ,@body)))
+  (let ((obj (gensym))
+	(ctype (convert-from-uffi-type (eval type) :allocate)))
+    (if (and (consp ctype) (eq 'array (car ctype)))
+	`(alien:with-alien ((,obj ,ctype))
+	  (let* ((,var ,obj))
+	    ,@body))
+	`(alien:with-alien ((,obj ,ctype))
+	  (let* ((,var (alien:addr ,obj)))
+	    ,@body))))
   #+sbcl
-  (let ((obj (gensym)))
-    `(sb-alien:with-alien ((,obj ,(convert-from-uffi-type (eval type) :allocate)))
-       (let ((,var (sb-alien:addr ,obj)))
-	 ,@body)))
+  (let ((obj (gensym))
+	(ctype (convert-from-uffi-type (eval type) :allocate)))
+    (if (and (consp ctype) (eq 'array (car ctype)))
+	`(sb-alien:with-alien ((,obj ,ctype))
+	  (let* ((,var ,obj))
+	    ,@body))
+	`(sb-alien:with-alien ((,obj ,ctype))
+	  (let* ((,var (sb-alien:addr ,obj)))
+	    ,@body))))
   #+lispworks
   `(fli:with-dynamic-foreign-objects ((,var ,(convert-from-uffi-type
 					      (eval type) :allocate)))
@@ -216,7 +232,7 @@ an array of TYPE with size SIZE. The TYPE parameter is evaluated."
            ,pointer (* ,(convert-from-uffi-type (eval type) :type)))))
     ,@body))
 
-#+allegro
+#+(or allegro openmcl)
 (defmacro with-cast-pointer ((binding-name pointer type) &body body)
   (declare (ignore type))
   `(let ((,binding-name ,pointer))
@@ -254,3 +270,37 @@ an array of TYPE with size SIZE. The TYPE parameter is evaluated."
     `(define-symbol-macro ,lisp-name
       '(error "DEF-FOREIGN-VAR not (yet) defined for ~A"
         (lisp-implementation-type)))))
+
+#-(or sbcl cmu)
+(defun convert-from-foreign-usb8 (s len)
+  (declare (optimize (speed 3) (space 0) (safety 0) (compilation-speed 0))
+	   (fixnum len))
+  (let ((a (make-array len :element-type '(unsigned-byte 8))))
+    (dotimes (i len a)
+      (declare (fixnum i))
+      (setf (aref a i) (uffi:deref-array s '(:array :unsigned-byte) i)))))
+
+#+sbcl
+(defun convert-from-foreign-usb8 (s len)
+  (declare (type sb-sys:system-area-pointer sap))
+  (locally
+      (declare (optimize (speed 3) (safety 0)))
+    (let ((result (make-array len :element-type '(unsiged-byte 8))))
+      (sb-kernel:copy-from-system-area s 0
+				       result (* sb-vm:vector-data-offset
+						 sb-vm:n-word-bits)
+				       (* len sb-vm:n-byte-bits))
+      result)))
+
+#+cmu
+(defun convert-from-foreign-usb8 (s le)
+  (declare (type system:system-area-pointer sap))
+  (locally
+      (declare (optimize (speed 3) (safety 0)))
+    (let ((result (make-array len :element-type '(unsiged-byte 8))))
+      (kernel:copy-from-system-area s 0
+				    result (* vm:vector-data-offset
+					      vm:word-bits)
+				    (* len vm:byte-bits))
+      result)))
+