Re: Coercing pointers

On Tue, 12 Aug 2003 08:22:53 -0600, Kevin Rosenberg <kevin-HJRc7zDS/[email protected]> wrote:

> You can try editing deref-array in aggregates.lisp to use the type
> field for cmucl and lispworks. Currently, that field is only used
> for Allegro which requires the type information since pointers are
> represented by integers with Allegro.
> 
> It appears that Lispworks, at least, can use fli:dereference to
> coerce from one pointer type to another.

OK, below is a patch.

With that patch my code now looks like this (which seems more natural
to me):

  (def-function ("gdImagePngPtr" gd-image-png-ptr)
      ((im gd-image-ptr)
       (size (* :int)))
    :returning :pointer-void
    :module "gd")

  (defun png-to-stream (stream image)
    (cond ((subtypep (stream-element-type stream) 'character)
            (with-foreign-object (size :int)
              (with-foreign-object (memory :char)
                (setq memory (gd-image-png-ptr image size))
                (dotimes (i (deref-pointer size :int))
                  (write-char (ensure-char-character (deref-array memory :char i))
                              stream)))))
          ((subtypep (stream-element-type stream) '(unsigned-byte 8))
            (with-foreign-object (size :int)
              (with-foreign-object (memory :unsigned-byte)
                (setq memory (gd-image-png-ptr image size))
                (dotimes (i (deref-pointer size :int))
                  (write-byte (deref-array memory :unsigned-byte i)
                              stream)))))
          (t (error "Can't use a stream with element-type ~A"
                    (stream-element-type stream)))))

I've tested this with CMUCL 18e and LW 4.2.7 pro on Linux. I've left
the #+(or cmu scl) stuff as is but I don't have SCL to test it.

However, this only works with CMUCL if I also make the change to
primitives.lisp (see below) which sets :CHAR in CMUCL to mean
(ALIEN:UNSIGNED 8). Is there a specific reason for (ALIEN:SIGNED 8)?

Cheers,
Edi.


  edi@bird:/usr/local/lisp/source/uffi/src > diff -u aggregates.lisp.orig aggregates.lisp
  --- aggregates.lisp.orig        Tue Aug 12 17:09:02 2003
  +++ aggregates.lisp     Tue Aug 12 16:40:26 2003
  @@ -158,11 +159,11 @@

   (defmacro deref-array (obj type i)
     "Returns a field from a row"
  -  #+(or lispworks cmu sbcl scl) (declare (ignore type))
  -  #+(or cmu scl)  `(alien:deref ,obj ,i)
  +  #+sbcl (declare (ignore type))
  +  #+(or cmu scl)  `(alien:deref (alien:cast ,obj (* ,(convert-from-uffi-type type :type))) ,i)
     #+sbcl  `(sb-alien:deref ,obj ,i)
  -  #+lispworks `(fli:dereference ,obj :index ,i)
     #+allegro `(ff:fslot-value-typed (quote ,(convert-from-uffi-type type :type)) :c ,obj ,i)
  +  #+lispworks `(fli:dereference ,obj :type (quote ,(convert-from-uffi-type type :type)) :index ,i)
     #+mcl
     (let* ((array-type (array-type type))
            (local-type (convert-from-uffi-type array-type :allocation))
  edi@bird:/usr/local/lisp/source/uffi/src > diff -u objects.lisp.orig objects.lisp
  --- objects.lisp.orig   Tue Aug 12 17:09:16 2003
  +++ objects.lisp        Tue Aug 12 16:40:58 2003
  @@ -103,10 +103,10 @@

   (defmacro deref-pointer (ptr type)
     "Returns a object pointed"
  -  #+(or cmu sbcl lispworks scl) (declare (ignore type))
  -  #+(or cmu scl)  `(alien:deref ,ptr)
  +  #+sbcl (declare (ignore type))
  +  #+(or cmu scl)  `(alien:deref (alien:cast ,ptr (* ,(convert-from-uffi-type type :type))))
     #+sbcl  `(sb-alien:deref ,ptr)
  -  #+lispworks `(fli:dereference ,ptr)
  +  #+lispworks `(fli:dereference ,ptr :type (quote ,(convert-from-uffi-type type :type)))
     #+allegro `(ff:fslot-value-typed (quote ,(convert-from-uffi-type type :deref)) :c ,ptr)
     #+mcl `(ccl:pref ,ptr ,(convert-from-uffi-type type :deref))
     )
  edi@bird:/usr/local/lisp/source/uffi/src > diff -u primitives.lisp.orig primitives.lisp
  --- primitives.lisp.orig        Tue Aug 12 17:09:27 2003
  +++ primitives.lisp     Tue Aug 12 17:08:08 2003
  @@ -91,7 +91,7 @@

   #+(or cmu scl)
   (defparameter *cmu-sbcl-def-type-list*
  -    '((:char . (alien:signed 8))
  +    '((:char . (alien:unsigned 8))
         (:unsigned-char . (alien:unsigned 8))
         (:byte . (alien:signed 8))
         (:unsigned-byte . (alien:unsigned 8))