;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
-;; $Id: interface.lisp,v 1.6 2007-09-07 07:28:42 espen Exp $
+;; $Id: interface.lisp,v 1.10 2008-12-10 02:40:18 espen Exp $
(in-package "GFFI")
#'string-capitalize
(cons prefix (split-string (symbol-name type-name) :delimiter #\-))))))
-(defun default-type-name (alien-name)
- (let ((parts
- (mapcar
- #'string-upcase
- (split-string-if alien-name #'upper-case-p))))
- (intern
- (concatenate-strings (rest parts) #\-)
- (find-prefix-package (first parts)))))
+(defun split-alien-name (alien-name)
+ (let ((parts (split-string-if alien-name #'upper-case-p)))
+ (do ((prefix (first parts) (concatenate 'string prefix (first rest)))
+ (rest (rest parts) (cdr rest)))
+ ((null rest)
+ (error "Couldn't split alien name '~A' to find a registered prefix"
+ alien-name))
+ (when (find-prefix-package prefix)
+ (return (values (string-upcase (concatenate-strings rest #\-))
+ (find-prefix-package prefix)))))))
+(defun default-type-name (alien-name)
+ (multiple-value-call #'intern (split-alien-name alien-name)))
(defun in-arg-p (style)
(find style '(:in :in/out :in/return :in-out :return)))
(list
(cond
((and (namep expr) (not (in-arg-p style))) expr)
- ((namep expr) (make-symbol (string expr)))
- ((gensym)))
+ ((namep expr)
+ #-clisp(make-symbol (string expr))
+ ;; The above used to work in CLISP, but I'm
+ ;; not sure exactly at which version it
+ ;; broke. The following could potentially
+ ;; cause variable capturing
+ #+clisp(intern (format nil "~A-~A" (string expr) (gensym))))
+ (#-clisp(gensym)
+ #+clisp(intern (string (gensym)))))
(or aux expr) type style out-type))))
args)))
when (out-arg-p style)
collect (return-type out-type)
when (return-arg-p style)
- collect (return-type type)))))))
+ collect (return-type type))))
+ ,lisp-name)))
(defun ,lisp-name ,lambda-list
,doc
(let ,aux-bindings
(let ((define-callback
#+cmu'alien:def-callback
#+(and sbcl alien-callbacks)'sb-alien::define-alien-callback
- #+(and sbcl (not alien-callbacks))'sb-alien:define-alien-function))
+ #+(and sbcl (not alien-callbacks))'sb-alien:define-alien-function)
+ (args (mapcar #'(lambda (arg)
+ (if (atom arg) (list arg arg) arg))
+ args)))
`(progn
#+cmu(defparameter ,name nil)
(,define-callback ,name
;;; translated according to RETTYPE. Obtain a pointer that can be
;;; passed to C code for this callback by calling %CALLBACK.
(defmacro define-callback (name return-type args &body body)
- (let ((arg-names (mapcar #'first args))
- (arg-types (mapcar #'second args)))
+ (let* ((args (mapcar #'(lambda (arg)
+ (if (atom arg) (list arg arg) arg))
+ args))
+ (arg-names (mapcar #'first args))
+ (arg-types (mapcar #'second args)))
`(progn
(defvar ,name ',name)
(register-callback ',name
;;;; Type expansion
+;; A hack to make the TYPE-EXPAND code for SBCL work.
+#?+(pkg-config:sbcl>= 1 0 35 15)
+(sb-ext:without-package-locks
+ (setf (symbol-function 'sb-kernel::type-expand)
+ (lambda (form) (typexpand form))))
+
(defun type-expand-1 (form)
#+(or cmu sbcl)
(let ((def (cond ((symbolp form)
(error "~A can not be expanded to ~A" form type))))))
(expand form)))
+(defun type-equal-p (type1 type2)
+ (and (subtypep type1 type2) (subtypep type2 type1)))
;;;; Type methods