Re: Idea/proposal/question DEF-FOREIGN-VAR

Sorry for being a PITA today, I realize I'm just too slow for
this. Anyway, below is a patch for DEF-FOREIGN-VAR against 1.3.0 which
will enhance the functionality for AllegroCL and LW. In my original
version this only worked with primitive types. The new version also
works with aggregates.

I've run the new version against your test suite with CMUCL, SBCL, LW,
and AllegroCL and they still pass all tests.

My test for a) aggregates and b) SETF-ability of the symbol macros
looks like this:

1. The C program which will be compiled into 'foo.so'.

  int baz = 3;

  typedef struct {
    int x;
    double y;
  } foo_struct;

  foo_struct the_struct = { 42, 3.2 };

  int foo () {
    return baz + the_struct.x;
  }

  double bar () {
    return the_struct.y;
  }

2. The Lisp program to test the correct behaviour:

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

  (uffi:def-struct foo-struct
    (x :int)
    (y :double))

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

  (uffi:def-function ("bar" bar)
      ()
    :returning :double
    :module "foo")

  (uffi:def-foreign-var ("baz" *baz*) :int "foo")
  (uffi:def-foreign-var ("the_struct" *the-struct*) foo-struct "foo")

  (defun test ()
    (assert (= *baz* 3))
    (assert (= (uffi:get-slot-value *the-struct* 'foo-struct 'x) 42))
    (assert (= (+ *baz* (uffi:get-slot-value *the-struct* 'foo-struct 'x))
               (foo)))
    (assert (= (uffi:get-slot-value *the-struct* 'foo-struct 'y) 3.2d0))
    (assert (= (uffi:get-slot-value *the-struct* 'foo-struct 'y)
               (bar)))
    (incf *baz* 3)
    (assert (= *baz* 6))
    (assert (= (foo) 48))
    (decf (uffi:get-slot-value *the-struct* 'foo-struct 'x) 10)
    (assert (= (foo) 38)))

This test also works with all four Lisps.

Think I have to go to bed now...

Cheers,
Edi.


--------------------------------- snip ---------------------------------

diff -ru /tmp/uffi-1.3.0/src/objects.lisp uffi/src/objects.lisp
--- /tmp/uffi-1.3.0/src/objects.lisp	Thu Aug 14 23:58:35 2003
+++ uffi/src/objects.lisp	Fri Aug 15 00:50:18 2003
@@ -232,19 +232,25 @@
   #-lispworks (declare (ignore module))
   (let ((foreign-name (if (atom names) names (first names)))
         (lisp-name (if (atom names) (make-lisp-name names) (second names)))
-        (var-type (convert-from-uffi-type type :foreign-var)))
+        #-allegro
+        (var-type (convert-from-uffi-type type :type)))
     #+(or cmu scl)
     `(alien:def-alien-variable (,foreign-name ,lisp-name) ,var-type)
     #+sbcl
     `(sb-alien:define-alien-variable (,foreign-name ,lisp-name) ,var-type)
     #+allegro
-    `(ff:def-foreign-variable (,lisp-name ,foreign-name) :convention :c
-      :type ,var-type)
+    `(define-symbol-macro ,lisp-name
+      (ff:fslot-value-typed (quote ,(convert-from-uffi-type type :deref))
+                            :c (ff:get-entry-point ,foreign-name)))
     #+lispworks
     (let ((temp-name (gensym)))
       `(progn
-        (fli:define-foreign-variable (,temp-name ,foreign-name) :type ,var-type :module ,module)
-        (define-symbol-macro ,lisp-name (,temp-name))))
+        (fli:define-foreign-variable (,temp-name ,foreign-name)
+                                     :accessor :address-of
+                                     :type ,var-type
+                                     :module ,module)
+        (define-symbol-macro ,lisp-name (fli:dereference (,temp-name)
+                                                         :copy-foreign-object nil))))
     #-(or allegro cmu scl sbcl lispworks)
     `(define-symbol-macro ,lisp-name
       '(error "DEF-FOREIGN-VAR not (yet) defined for ~A"
diff -ru /tmp/uffi-1.3.0/src/primitives.lisp uffi/src/primitives.lisp
--- /tmp/uffi-1.3.0/src/primitives.lisp	Thu Aug 14 23:58:35 2003
+++ uffi/src/primitives.lisp	Fri Aug 15 00:58:11 2003
@@ -85,8 +85,6 @@
   (defvar +type-conversion-hash+ (make-hash-table :size 20 :test #'eq))
   #+(or cmu sbcl scl) (defvar *cmu-def-type-hash*
 			(make-hash-table :size 20 :test #'eq))
-  #+allegro (defvar *allegro-foreign-type-hash*
-	      (make-hash-table :size 20 :test #'eq))
   )
 
 #+(or cmu sbcl scl)
@@ -223,23 +221,6 @@
        (:float . :single-float) (:double . :double-float)
        (:array . :array)))
 
-#+allegro
-(defvar *allegro-foreign-type-list*
-    '((:char . :signed-byte)
-      (:unsigned-char . :unsigned-byte)
-      (:byte . :signed-byte)
-      (:unsigned-byte . :unsigned-byte)
-      (:short . :signed-word)
-      (:unsigned-short . :unsigned-word)
-      (:int . :signed-long)
-      (:unsigned-int . :unsigned-long32)
-      (:long . :signed-long)
-      (:unsigned-long . :unsigned-long)
-      (:float . :single-float)
-      (:double . :double-float)
-      )
-  "Conversion for Allegro's system:memref function")
-
 (dolist (type *type-conversion-list*)
   (setf (gethash (car type) +type-conversion-hash+) (cdr type)))
 
@@ -247,14 +228,6 @@
 (dolist (type *cmu-sbcl-def-type-list*)
   (setf (gethash (car type) *cmu-def-type-hash*) (cdr type)))
 
-#+allegro
-(dolist (type *allegro-foreign-type-list*)
-  (setf (gethash (car type) *allegro-foreign-type-hash*) (cdr type)))
-
-(defun foreign-var-type-convert (type)
-  #+allegro (gethash type *allegro-foreign-type-hash*))
-
-  
 (defun basic-convert-from-uffi-type (type)
   (let ((found-type (gethash type +type-conversion-hash+)))
     (if found-type
@@ -282,9 +255,6 @@
 	(basic-convert-from-uffi-type :cstring-returning))
        #+(and mcl (not openmcl))
        ((and (eq type :void) (eq context :return)) nil)
-       #+allegro
-       ((eq context :foreign-var)
-	(foreign-var-type-convert type))
        (t
 	(basic-convert-from-uffi-type type)))
     (let ((sub-type (car type)))