Proposal WITH-CASTED-POINTER (Was: Coercing pointers)

I wrote:

> > OK, I'll see what I need for GD and send patches later. I
> > currently think it'd be best to mix the two approaches we talked
> > about and document this accordingly.

Forget what I just said... :)

Here's a proposal (patch at the end of this email):

  Macro WITH-CASTED-POINTER (pointer type &optional binding-name) &body body

  Executes BODY with POINTER casted to be a pointer to type TYPE. If
  BINDING-NAME is provided the casted pointer will be bound to this
  name during the execution of BODY. If BINDING-NAME is not provided
  POINTER must be a name bound to the pointer which should be
  casted. This name will be bound to the casted pointer during the
  execution of BODY.

  This is a no-op in AllegroCL but will wrap BODY in a LET form if
  BINDING-NAME is provided.

  This macro is meant to be used in conjunction with DEREF-POINTER or
  DEREF-ARRAY. In Allegro CL the "cast" will actually take place in
  DEREF-POINTER or DEREF-ARRAY.

The docs for DEREF-POINTER and DEREF-ARRAY should get the following
note:

  The TYPE argument is ignored for CL implementations other than
  AllegroCL. If you want to cast a pointer to another type use
  WITH-CASTED-POINTER together with DEREF-POINTER/DEREF-ARRAY.

Rationale:

1. I didn't use the name WITH-COERCED-POINTER because it's already
   taken by LW.

2. It'd probably be nicer to have a function CAST-POINTER instead of a
   macro but I think this is not an option because LW doesn't seem to
   offer this - you have to use their WITH-COERCED-POINTER.

3. It would be more natural to have 

     WITH-CASTED-POINTER (binding-name pointer type) &body body

   but having your last remarks in mind I thought this might be a
   performance penalty for AllegroCL because of the unnecessary LET
   form. (Or do you think the compiler will be able to optimize it
   away?)

Tests:

I've tested with CMUCL 18e, AllegroCL 6.2 trial, LW 4.2.7 pro and SBCL
0.8.2 - all on Linux. I used the following C function

  void *foo (int n) {
    int *x;
    double *y;

    if (n > 0) {
      x = (int *) malloc(sizeof(int));
      *x = 23;
      return x;
    } else {
      y = (double *) malloc(sizeof(double));
      *y = 3.21;
      return y;
    }
  }

and this Lisp code

  (uffi:load-foreign-library "/tmp/test/foo.so"
                               :module "foo")

  (uffi:def-function "foo"
      ((n :int))
    :returning :pointer-void
    :module "foo")

  (defun test (n)
    (cond ((plusp n)
            (uffi:with-casted-pointer ((foo n) :int temp)
              (assert (= (uffi:deref-pointer temp :int) 23)))
            (let ((result (foo n)))
              (uffi:with-casted-pointer (result :int)
                (assert (= (uffi:deref-pointer result :int) 23)))
              (uffi:with-casted-pointer (result :int temp)
                (assert (= (uffi:deref-pointer temp :int) 23)))))
          (t 
            (uffi:with-casted-pointer ((foo n) :double temp)
              (assert (= (uffi:deref-pointer temp :double) 3.21d0)))
            (let ((result (foo n)))
              (uffi:with-casted-pointer (result :double)
                (assert (= (uffi:deref-pointer result :double) 3.21d0)))
              (uffi:with-casted-pointer (result :double temp)
                (assert (= (uffi:deref-pointer temp :double) 3.21d0)))))))

The tests ran fine on all four implementations, interpreted as well as
compiled.

Let me know what you think,
Edi.


---------------------------------- SNIP -----------------------------

edi@bird:/usr/local/lisp/source/uffi/src > diff -ru /tmp/uffi-1.2.21/ /usr/local/lisp/source/uffi
diff -ru /tmp/uffi-1.2.21/src/objects.lisp /usr/local/lisp/source/uffi/src/objects.lisp
--- /tmp/uffi-1.2.21/src/objects.lisp   Tue Jul  8 14:37:26 2003
+++ /usr/local/lisp/source/uffi/src/objects.lisp        Thu Aug 14 00:00:17 2003
@@ -197,3 +197,33 @@
   `(with-foreign-objects ((,var ,type))
      ,@body))

+#+lispworks
+(defmacro with-casted-pointer ((pointer type &optional binding-name) &body body)
+  `(fli:with-coerced-pointer (,(or binding-name pointer)
+                          :type ',(convert-from-uffi-type (eval type) :type))
+      ,pointer
+    ,@body))
+
+#+(or cmu scl sbcl)
+(defmacro with-casted-pointer ((pointer type &optional binding-name) &body body)
+  `(let ((,(or binding-name pointer)
+          (#+(or cmu scl) alien:cast
+           #+sbcl sb-alien:cast
+           ,pointer (* ,(convert-from-uffi-type (eval type) :type)))))
+    ,@body))
+
+#+allegro
+(defmacro with-casted-pointer ((pointer type &optional binding-name) &body body)
+  (declare (ignore type))
+  (cond (binding-name
+          `(let ((,binding-name ,pointer))
+            ,@body))
+        (t
+          `(progn
+            ,@body))))
+
+#-(or lispworks cmu scl sbcl allegro)
+(defmacro with-casted-pointer ((pointer type &optional binding-name) &body body)
+  '(error "WITH-CASTED-POINTER not (yet) implemented for ~A"
+          (lisp-implementation-type)))
+
diff -ru /tmp/uffi-1.2.21/src/package.lisp /usr/local/lisp/source/uffi/src/package.lisp
--- /tmp/uffi-1.2.21/src/package.lisp   Sat Jun  7 00:06:28 2003
+++ /usr/local/lisp/source/uffi/src/package.lisp        Wed Aug 13 16:45:23 2003
@@ -49,6 +49,7 @@
    #:make-null-pointer
    #:+null-cstring-pointer+
    #:char-array-to-pointer
+   #:with-casted-pointer

    ;; string functions
    #:convert-from-cstring