;;;; Programmers: Kevin M. Rosenberg and John DeSoi
;;;; Date Started: Feb 2002
;;;;
-;;;; $Id: primitives.cl,v 1.2 2002/09/20 04:51:14 kevin Exp $
+;;;; $Id: primitives.cl,v 1.4 2002/09/30 01:57:32 kevin Exp $
;;;;
;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
;;;; and John DeSoi
(defmacro def-foreign-type (name uffi-type)
(let ((type (convert-from-uffi-type uffi-type :type)))
- (unless (keywordp type)
+ (unless (or (keywordp type) (consp type))
(setf type `(quote ,type)))
#-openmcl
`(def-mcl-type ,(keyword name) ,type)
(defvar +type-conversion-hash+ (make-hash-table :size 20)))
#-openmcl
-(defconstant +type-conversion-list+
- '((* . :pointer) (:void . :void)
- (:short . :short)
- (:pointer-void . :pointer)
- (:cstring . :string)
- (:char . :character)
- (:unsigned-char . :unsigned-byte)
- (:byte . :signed-byte) (:unsigned-byte . :unsigned-byte)
- (:int . :integer) (:unsigned-int . :unsigned-integer)
- (:long . :long) (:unsigned-long . :unsigned-long)
- (:float . :single-float) (:double . :double-float)
- (:array . :array)))
+(defconstant +type-conversion-list+
+ '((* . :pointer) (:void . :void)
+ (:short . :short) (:unsigned-short . :unsigned-short)
+ (:pointer-void . :pointer)
+ (:cstring . :string)
+ (:char . :character)
+ (:unsigned-char . :unsigned-byte)
+ (:byte . :signed-byte) (:unsigned-byte . :unsigned-byte)
+ (:int . :long) (:unsigned-int . :unsigned-long)
+ (:long . :long) (:unsigned-long . :unsigned-long)
+ (:float . :single-float) (:double . :double-float)
+ (:array . :array)))
#+openmcl
-(defconstant +type-conversion-list+
- '((* . :address) (:void . :void)
- (:short . :short)
- (:pointer-void . :address)
- (:cstring . :address)
- (:char . :signed-char)
- (:unsigned-char . :unsigned-char)
- (:byte . :signed-byte) (:unsigned-byte . :unsigned-byte)
- (:int . :int) (:unsigned-int . :unsigned-int)
- (:long . :long) (:unsigned-long . :unsigned-long)
- (:long-long . :signed-doubleword) (:unsigned-long-long . :unsigned-doubleword)
- (:float . :single-float) (:double . :double-float)
- (:array . :array)))
+(defconstant +type-conversion-list+
+ '((* . :address) (:void . :void)
+ (:short . :short) (:unsigned-short . :unsigned-short)
+ (:pointer-void . :address)
+ (:cstring . :address)
+ (:char . :signed-char)
+ (:unsigned-char . :unsigned-char)
+ (:byte . :signed-byte) (:unsigned-byte . :unsigned-byte)
+ (:int . :int) (:unsigned-int . :unsigned-int)
+ (:long . :long) (:unsigned-long . :unsigned-long)
+ (:long-long . :signed-doubleword) (:unsigned-long-long . :unsigned-doubleword)
+ (:float . :single-float) (:double . :double-float)
+ (:array . :array)))
+
(dolist (type +type-conversion-list+)
(setf (gethash (car type) +type-conversion-hash+) (cdr type)))
"Converts from a uffi type to an implementation specific type"
(if (atom type)
(cond
- #-openmcl
- ((and (eq type :void) (eq context :return)) nil)
+ #-openmcl ((and (eq type :void) (eq context :return)) nil)
(t (basic-convert-from-uffi-type type)))
- (if (eq (car type) 'cl:quote)
- (%convert-from-uffi-type (cadr type) context)
- (cons (%convert-from-uffi-type (first type) context)
- (%convert-from-uffi-type (rest type) context)))))
+ (let ((sub-type (car type)))
+ (case sub-type
+ (cl:quote
+ (%convert-from-uffi-type (cadr type) context))
+ (:struct-pointer
+ #+openmcl `(:* (:struct ,(convert-from-uffi-type (cadr type) :struct)))
+ #-openmcl `(,(convert-from-uffi-type (list '* (cadr type)) :struct))
+ )
+ (:struct
+ #+openmcl `(:struct ,(convert-from-uffi-type (cadr type) :struct))
+ #-openmcl `(,(convert-from-uffi-type (cadr type) :struct))
+ )
+ (t
+ (cons (%convert-from-uffi-type (first type) context)
+ (%convert-from-uffi-type (rest type) context)))))))
(defun convert-from-uffi-type (type context)
(let ((result (%convert-from-uffi-type type context)))
(cond
((atom result) result)
#+openmcl
- ((eq (car result) :address) :address)
+ ((eq (car result) :address)
+ (if (eq context :struct)
+ (append '(:*) (cdr result))
+ :address))
#-openmcl
((and (eq (car result) :pointer) (eq context :allocation) :pointer))
(t result))))