uffi/src objects.lisp,1.16,1.17 package.lisp,1.5,1.6 primitives.lisp,1.9,1.10

Update of /pubcvs/uffi/src
In directory boa.b9.com:/tmp/cvs-serv19046/src

Modified Files:
	objects.lisp package.lisp primitives.lisp 
Log Message:
def-foreign-var support

Index: objects.lisp
===================================================================
RCS file: /pubcvs/uffi/src/objects.lisp,v
retrieving revision 1.16
retrieving revision 1.17
diff -C2 -d -r1.16 -r1.17
*** objects.lisp	14 Aug 2003 19:35:05 -0000	1.16
--- objects.lisp	14 Aug 2003 21:40:13 -0000	1.17
***************
*** 229,230 ****
--- 229,251 ----
            (lisp-implementation-type)))
  
+ (defmacro def-foreign-var (names type module)
+   #-lispworks (declare (ignore module))
+   (let ((foreign-name (if (atom names) names (first names)))
+         (lisp-name (if (atom names) (uffi::make-lisp-name names) (second names)))
+         (var-type (uffi::convert-from-uffi-type type :foreign-var)))
+     #+(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)
+     #+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))))
+     #-(or allegro cmu scl sbcl lispworks)
+     `(define-symbol-macro ,lisp-name
+       '(error "DEF-FOREIGN-VAR not (yet) defined for ~A"
+         (lisp-implementation-type)))))

Index: primitives.lisp
===================================================================
RCS file: /pubcvs/uffi/src/primitives.lisp,v
retrieving revision 1.9
retrieving revision 1.10
diff -C2 -d -r1.9 -r1.10
*** primitives.lisp	6 Jun 2003 21:59:18 -0000	1.9
--- primitives.lisp	14 Aug 2003 21:40:13 -0000	1.10
***************
*** 83,95 ****
  
  (eval-when (:compile-toplevel :load-toplevel :execute)
!   (defvar +type-conversion-hash+ (make-hash-table :size 20))
!   #+(or cmu sbcl scl) (defvar *cmu-def-type-hash* (make-hash-table :size 20))
    )
  
  #+(or cmu sbcl scl)
! (defparameter *cmu-sbcl-def-type-list* nil)
  
  #+(or cmu scl)
! (defparameter *cmu-sbcl-def-type-list*
      '((:char . (alien:signed 8))
        (:unsigned-char . (alien:unsigned 8))
--- 83,98 ----
  
  (eval-when (:compile-toplevel :load-toplevel :execute)
!   (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)
! (defvar *cmu-sbcl-def-type-list* nil)
  
  #+(or cmu scl)
! (defvar *cmu-sbcl-def-type-list*
      '((:char . (alien:signed 8))
        (:unsigned-char . (alien:unsigned 8))
***************
*** 107,111 ****
    "Conversions in CMUCL for def-foreign-type are different than in def-function")
  #+sbcl
! (defparameter *cmu-sbcl-def-type-list*
      '((:char . (sb-alien:signed 8))
        (:unsigned-char . (sb-alien:unsigned 8))
--- 110,114 ----
    "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))
        (:unsigned-char . (sb-alien:unsigned 8))
***************
*** 123,127 ****
    "Conversions in SBCL for def-foreign-type are different than in def-function")
  
! (defparameter *type-conversion-list* nil)
  
  #+(or cmu scl)
--- 126,130 ----
    "Conversions in SBCL for def-foreign-type are different than in def-function")
  
! (defvar *type-conversion-list* nil)
  
  #+(or cmu scl)
***************
*** 223,226 ****
--- 226,246 ----
         (: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)))
***************
*** 230,233 ****
--- 250,261 ----
    (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+)))
***************
*** 257,260 ****
--- 285,291 ----
         #+(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)))

Index: package.lisp
===================================================================
RCS file: /pubcvs/uffi/src/package.lisp,v
retrieving revision 1.5
retrieving revision 1.6
diff -C2 -d -r1.5 -r1.6
*** package.lisp	14 Aug 2003 19:35:05 -0000	1.5
--- package.lisp	14 Aug 2003 21:40:13 -0000	1.6
***************
*** 51,54 ****
--- 51,55 ----
     #:char-array-to-pointer
     #:with-cast-pointer
+    #:def-foreign-var
     
     ;; string functions