r9012: add make-pointer and pointer-address

diff --git a/ChangeLog b/ChangeLog
index 4c50f909efc00beb4a0aad04cb65a54c1714d292..4c0ea2e0e54dc8981f4c5c617eefd1afa9f8c4b1 100644 (file)
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,5 +1,9 @@
+2004-04-15 Kevin Rosenberg (kevin@rosenberg.net)
+       * src/objects.lisp: Add new functions:
+       MAKE-POINTER and POINTER-ADDRESS
+
 2004-04-13 Kevin Rosenberg (kevin@rosenberg.net)
-       * str/string.lisp: Add new FOREIGN-STRING-LENGTH
+       * src/string.lisp: Add new FOREIGN-STRING-LENGTH
 
 2003-08-15 Kevin Rosenberg (kevin@rosenberg.net)
        * Added with-cast-pointer and def-foreign-var (patches submitted

diff --git a/debian/changelog b/debian/changelog
index 4edda68037043cb0f097e565429e03cd25b976b3..2994cb61e5d43e48e5096da63bc63d25a104fb4b 100644 (file)
--- a/debian/changelog
+++ b/debian/changelog
@@ -1,3 +1,9 @@
+cl-uffi (1.4.10-1) unstable; urgency=low
+
+  * New upstream
+
+ -- Kevin M. Rosenberg <kmr@debian.org>  Thu, 15 Apr 2004 01:59:37 -0600
+
 cl-uffi (1.4.9-1) unstable; urgency=low
 
   * New upstream

diff --git a/src/functions.lisp b/src/functions.lisp
index 7f0939d5afe2dd20fdcf7d7264096483a39e51fb..1b6b32501f4d8bc044d6877b5233eaa8fc019bc9 100644 (file)
--- a/src/functions.lisp
+++ b/src/functions.lisp
@@ -117,10 +117,5 @@
     ))
 
 
-(defun make-lisp-name (name)
-  (let ((converted (substitute #\- #\_ name)))
-     (intern 
-      #+case-sensitive converted
-      #-case-sensitive (string-upcase converted))))
 
 

diff --git a/src/objects.lisp b/src/objects.lisp
index dc382f52627ff41022aa43ce34a15bcfd030dd44..82a9d0e8270960c5041310aa0bc1d59c0ef81527 100644 (file)
--- a/src/objects.lisp
+++ b/src/objects.lisp
@@ -92,6 +92,22 @@ 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 pointer-address (ptr)
+  #+allegro ptr
+  #+(or cmu scl) `(system:sap-int (alien:alien-sap ,ptr))
+  #+sbcl `(sb-sys:sap-int (sb-alien:alien-sap ,ptr))
+  #+lispworks `(fli:pointer-address ,ptr)
+  #+mcl `(ccl:%ptr-to-int ,ptr))
+
 (defmacro char-array-to-pointer (obj)
   #+(or cmu scl) `(alien:cast ,obj (* (alien:unsigned 8)))
   #+sbcl `(sb-alien:cast ,obj (* (sb-alien:unsigned 8)))

diff --git a/src/package.lisp b/src/package.lisp
index 05f7e4f5d6802e1687f63fc494a7c2d1573c4a6b..4744635c2c92c828bb3d9a5ed8c8c7684e0aa8f6 100644 (file)
--- a/src/package.lisp
+++ b/src/package.lisp
@@ -47,6 +47,8 @@
    #:ensure-char-integer
    #:null-pointer-p
    #:make-null-pointer
+   #:make-pointer
+   #:pointer-address
    #:+null-cstring-pointer+
    #:char-array-to-pointer
    #:with-cast-pointer

diff --git a/src/primitives.lisp b/src/primitives.lisp
index 007355c316209082abc7d6d22886cfe297b3403a..c430894f711922ace55c007c5e25b1e660128575 100644 (file)
--- a/src/primitives.lisp
+++ b/src/primitives.lisp
@@ -87,9 +87,6 @@ supports takes advantage of this optimization."
                        (make-hash-table :size 20 :test #'eq))
   )
 
-#+(or cmu sbcl scl)
-(defvar *cmu-sbcl-def-type-list* nil)
-
 #+(or cmu scl)
 (defvar *cmu-sbcl-def-type-list*
     '((:char . (alien:signed 8))
@@ -104,8 +101,10 @@ supports takes advantage of this optimization."
       (:unsigned-long . (alien:unsigned 32))
       (:float . alien:single-float)
       (:double . alien:double-float)
+      (:void . t)
       )
   "Conversions in CMUCL for def-foreign-type are different than in def-function")
+
 #+sbcl
 (defvar *cmu-sbcl-def-type-list*
     '((:char . (sb-alien:signed 8))
@@ -120,6 +119,7 @@ supports takes advantage of this optimization."
       (:unsigned-long . (sb-alien:unsigned 32))
       (:float . sb-alien:single-float)
       (:double . sb-alien:double-float)
+      (:void . t)
       )
   "Conversions in SBCL for def-foreign-type are different than in def-function")
 
@@ -286,3 +286,9 @@ supports takes advantage of this optimization."
      ((and (eq (car result) :pointer) (eq context :allocation) :pointer))
      (t result))))
 
+
+(defun make-lisp-name (name)
+  (let ((converted (substitute #\- #\_ name)))
+     (intern 
+      #+case-sensitive converted
+      #-case-sensitive (string-upcase converted))))

diff --git a/src/strings.lisp b/src/strings.lisp
index 4671925661c8b67298d5879a233524e08e9619f7..6e7292cff8e8e89ea4f3a2f4b0a2dc8fb91fe996 100644 (file)
--- a/src/strings.lisp
+++ b/src/strings.lisp
@@ -193,20 +193,26 @@ that LW/CMU automatically converts strings from c-calls."
 
 
 (defmacro allocate-foreign-string (size &key (unsigned t))
-  #+(or cmu scl)
+  #+ignore
   (let ((array-def (gensym)))
     `(let ((,array-def (list 'alien:array 'c-call:char ,size)))
        (eval `(alien:cast (alien:make-alien ,,array-def) 
                          ,(if ,unsigned 
                               '(* (alien:unsigned 8))
                             '(* (alien:signed 8)))))))
+
+  #+(or cmu scl)
+  `(alien:make-alien ,(if unsigned 
+                            '(alien:unsigned 8)
+                            '(alien:signed 8))
+    ,size)
+
   #+sbcl
-  (let ((array-def (gensym)))
-    `(let ((,array-def (list 'sb-alien:array 'char ,size)))
-       (eval `(sb-alien:cast (sb-alien:make-alien ,,array-def) 
-                         ,(if ,unsigned 
-                              '(* (sb-alien:unsigned 8))
-                            '(* (sb-alien:signed 8)))))))
+  `(sb-alien:make-alien ,(if unsigned 
+                            '(sb-alien:unsigned 8)
+                            '(sb-alien:signed 8))
+    ,size)
+
   #+lispworks
   `(fli:allocate-foreign-object :type 
                                ,(if unsigned 
@@ -227,7 +233,7 @@ that LW/CMU automatically converts strings from c-calls."
   #+allegro `(ff:foreign-strlen ,foreign-string)
   #-allegro
   `(loop with size = 0
-    until (char= (deref-array ,ptr '(:array :unsigned-char) size) #\Null)
+    until (char= (deref-array ,foreign-string '(:array :unsigned-char) size) #\Null)
     do (incf size)
     finally return size))