Permalink
Browse files

stdcall, namespaces, close-foreign-library

Three new features:
  - stdcall (defcfun, foreign-funcall(-pointer), defcallback)
  - namespaces, associate foreigns vars and functions to a
    specific library. (CLISP and Lispworks only)
  - close-foreign-library actually works now.

Backwards incompatible changes:
  - define-foreign-library's syntax changed slightly, can't
    load more than one foreign library per define-foreign-library
    form anymore.
  - defcvar's syntax changed.
  - foreign-funcall can't funcall pointers anymore. Use
    foreign-funcall-pointer for that.
  • Loading branch information...
1 parent e5e4268 commit 4f37c6d98a4947c090fbd69e079d0865b42ca750 @luismbo luismbo committed Feb 14, 2007
View
@@ -2,7 +2,7 @@
;;;
;;; cffi-allegro.lisp --- CFFI-SYS implementation for Allegro CL.
;;;
-;;; Copyright (C) 2005-2006, Luis Oliveira <loliveira(@)common-lisp.net>
+;;; Copyright (C) 2005-2007, Luis Oliveira <loliveira(@)common-lisp.net>
;;;
;;; Permission is hereby granted, free of charge, to any person
;;; obtaining a copy of this software and associated documentation
@@ -52,7 +52,7 @@
#:%mem-set
;#:make-shareable-byte-vector
;#:with-pointer-to-vector-data
- #:foreign-symbol-pointer
+ #:%foreign-symbol-pointer
#:defcfun-helper-forms
#:%defcallback
#:%callback
@@ -67,6 +67,7 @@
(mapc (lambda (feature) (pushnew feature *features*))
'(;; Backend mis-features.
cffi-features:no-long-long
+ cffi-features:flat-namespace
;; OS/CPU features.
#+macosx cffi-features:darwin
#+unix cffi-features:unix
@@ -140,7 +141,7 @@ SIZE-VAR is supplied, it will be bound to SIZE during BODY."
(declare (ignorable ,size-var))
(ff:with-stack-fobject (,var :char :c ,size-var)
,@body)))
-
+
;;;# Shareable Vectors
;;;
;;; This interface is very experimental. WITH-POINTER-TO-VECTOR-DATA
@@ -280,7 +281,8 @@ SIZE-VAR is supplied, it will be bound to SIZE during BODY."
nil ; arg-checking
ff::ep-flag-never-release))))
-(defmacro %foreign-funcall (name &rest args)
+(defmacro %foreign-funcall (name args &key calling-convention library)
+ (declare (ignore calling-convention library))
(multiple-value-bind (types fargs rettype)
(foreign-funcall-type-and-args args)
`(system::ff-funcall
@@ -296,12 +298,13 @@ SIZE-VAR is supplied, it will be bound to SIZE during BODY."
;; return type '(:c-type lisp-type)
',(allegro-type-pair rettype))))
-(defun defcfun-helper-forms (name lisp-name rettype args types)
+(defun defcfun-helper-forms (name lisp-name rettype args types options)
"Return 2 values for DEFCFUN. A prelude form and a caller form."
+ (declare (ignore options))
(let ((ff-name (intern (format nil "%cffi-foreign-function/~A" lisp-name))))
(values
`(ff:def-foreign-call (,ff-name ,name)
- ,(mapcar (lambda (ty)
+ ,(mapcar (lambda (ty)
(let ((allegro-type (convert-foreign-type ty)))
(list (gensym) allegro-type
(convert-to-lisp-type allegro-type))))
@@ -315,7 +318,8 @@ SIZE-VAR is supplied, it will be bound to SIZE during BODY."
`(,ff-name ,@args))))
;;; See doc/allegro-internals.txt for a clue about entry-vec.
-(defmacro %foreign-funcall-pointer (ptr &rest args)
+(defmacro %foreign-funcall-pointer (ptr args &key calling-convention)
+ (declare (ignore calling-convention))
(multiple-value-bind (types fargs rettype)
(foreign-funcall-type-and-args args)
(with-unique-names (entry-vec)
@@ -328,7 +332,7 @@ SIZE-VAR is supplied, it will be bound to SIZE during BODY."
`(',(allegro-type-pair type) ,arg))
types fargs)
;; return type '(:c-type lisp-type)
- ',(allegro-type-pair rettype))))))
+ ',(allegro-type-pair rettype))))))
;;;# Callbacks
@@ -360,7 +364,7 @@ SIZE-VAR is supplied, it will be bound to SIZE during BODY."
;;; CFFI is restarted.
(eval-when (:load-toplevel :execute)
(pushnew 'restore-callbacks excl:*restart-actions*))
-
+
;;; Create a package to contain the symbols for callback functions.
(defpackage #:cffi-callbacks
(:use))
@@ -370,15 +374,21 @@ SIZE-VAR is supplied, it will be bound to SIZE during BODY."
(symbol-name name))
'#:cffi-callbacks))
-(defmacro %defcallback (name rettype arg-names arg-types &body body)
+(defun convert-cconv (cconv)
+ (ecase cconv
+ (:cdecl :c)
+ (:stdcall :stdcall)))
+
+(defmacro %defcallback (name rettype arg-names arg-types body
+ &key calling-convention)
(declare (ignore rettype))
(let ((cb-name (intern-callback name)))
`(progn
(ff:defun-foreign-callable ,cb-name
,(mapcar (lambda (sym type) (list sym (convert-foreign-type type)))
arg-names arg-types)
- (declare (:convention :c))
- ,@body)
+ (declare (:convention ,(convert-cconv calling-convention)))
+ ,body)
(register-callback ',name ',cb-name))))
;;; Return the saved Lisp callback pointer from *CALLBACKS* for the
@@ -389,17 +399,20 @@ SIZE-VAR is supplied, it will be bound to SIZE during BODY."
;;;# Loading and Closing Foreign Libraries
-(defun %load-foreign-library (name)
- "Load the foreign library NAME."
+(defun %load-foreign-library (name path)
+ "Load a foreign library."
;; ACL 8.0 honors the :FOREIGN option and always tries to foreign load
;; the argument. However, previous versions do not and will only
;; foreign load the argument if its type is a member of the
;; EXCL::*LOAD-FOREIGN-TYPES* list. Therefore, we bind that special
;; to a list containing whatever type NAME has.
+ (declare (ignore name))
(let ((excl::*load-foreign-types*
- (list (pathname-type (parse-namestring name)))))
- (ignore-errors #+(version>= 7) (load name :foreign t)
- #-(version>= 7) (load name))))
+ (list (pathname-type (parse-namestring path)))))
+ (ignore-errors
+ #+(version>= 7) (load path :foreign t)
+ #-(version>= 7) (load path)
+ path)))
(defun %close-foreign-library (name)
"Close the foreign library NAME."
@@ -415,8 +428,9 @@ SIZE-VAR is supplied, it will be bound to SIZE during BODY."
#+macosx (concatenate 'string "_" name)
#-macosx name)
-(defun foreign-symbol-pointer (name)
+(defun %foreign-symbol-pointer (name library)
"Returns a pointer to a foreign symbol NAME."
+ (declare (ignore library))
(prog1 (ff:get-entry-point (convert-external-name name))))
;;;# Finalizers
@@ -441,4 +455,4 @@ accessible when FUNCTION is invoked."
"Cancels all of OBJECT's finalizers, if any."
(mapc #'excl:unschedule-finalization
(gethash object *finalizers*))
- (remhash object *finalizers*))
+ (remhash object *finalizers*))
View
@@ -51,8 +51,6 @@
#:native-namestring
#:%mem-ref
#:%mem-set
- #:make-shareable-byte-vector
- #:with-pointer-to-vector-data
#:foreign-symbol-pointer
#:%defcallback
#:%callback
@@ -207,7 +205,8 @@ foreign TYPE to VALUE."
(if (constantp type)
;; (setf (ffi:memory-as) value) is exported, but not so nice
;; w.r.t. the left to right evaluation rule
- `(ffi::write-memory-as ,value ,ptr ',(convert-foreign-type (eval type)) ,offset)
+ `(ffi::write-memory-as
+ ,value ,ptr ',(convert-foreign-type (eval type)) ,offset)
form))
;;;# Shareable Vectors
@@ -243,57 +242,73 @@ WITH-POINTER-TO-VECTOR-DATA."
;;;# Foreign Function Calling
(defun parse-foreign-funcall-args (args)
- "Return three values, a list of CLisp FFI types, a list of
-values to pass to the function, and the CLisp FFI return type."
+ "Return three values, a list of CLISP FFI types, a list of
+values to pass to the function, and the CLISP FFI return type."
(let ((return-type nil))
(loop for (type arg) on args by #'cddr
if arg collect (list (gensym) (convert-foreign-type type)) into types
and collect arg into fargs
else do (setf return-type (convert-foreign-type type))
finally (return (values types fargs return-type)))))
-(defmacro %foreign-funcall (name &rest args)
+(defun convert-cconv (calling-convention)
+ (ecase calling-convention
+ (:stdcall :stdc-stdcall)
+ (:cdecl :stdc)))
+
+(defun c-function-type (arg-types rettype calling-convention)
+ "Generate the apropriate CLISP foreign type specification. Also
+takes care of converting the calling convention names."
+ `(ffi:c-function (:arguments ,@arg-types)
+ (:return-type ,rettype)
+ (:language ,(convert-cconv calling-convention))))
+
+;;; Quick hack around the fact that the CFFI package is not yet
+;;; defined when this file is loaded. I suppose we could arrange for
+;;; the CFFI package to be defined a bit earlier, though.
+(defun library-handle-form (name)
+ (flet ((find-cffi-symbol (symbol)
+ (find-symbol (symbol-name symbol) '#:cffi)))
+ `(,(find-cffi-symbol '#:foreign-library-handle)
+ (,(find-cffi-symbol '#:get-foreign-library) ',name))))
+
+(defmacro %foreign-funcall (name args &key library calling-convention)
"Invoke a foreign function called NAME, taking pairs of
foreign-type/value pairs from ARGS. If a single element is left
over at the end of ARGS, it specifies the foreign return type of
the function call."
(multiple-value-bind (types fargs rettype)
(parse-foreign-funcall-args args)
- (let ((ctype `(ffi:c-function (:arguments ,@types)
- (:return-type ,rettype)
- (:language :stdc))))
- `(funcall
- (load-time-value
- (multiple-value-bind (ff error)
- (ignore-errors
- (ffi::foreign-library-function
- ,name (ffi::foreign-library :default)
- nil
- ;; As of version 2.40 (CVS 2006-09-03, to be more precise),
- ;; FFI::FOREIGN-LIBRARY-FUNCTION takes an additional
- ;; 'PROPERTIES' argument.
- #+#.(cl:if (cl:= (cl:length (ext:arglist
- 'ffi::foreign-library-function)) 5)
- '(and) '(or))
- nil
- (ffi:parse-c-type ',ctype)))
- (or ff
- (warn (format nil "~?"
- (simple-condition-format-control error)
- (simple-condition-format-arguments error))))))
- ,@fargs))))
-
-(defmacro %foreign-funcall-pointer (ptr &rest args)
+ `(funcall
+ (load-time-value
+ (handler-case
+ (ffi::foreign-library-function
+ ,name
+ ,(if (eq library :default)
+ :default
+ (library-handle-form library))
+ nil
+ ;; As of version 2.40 (CVS 2006-09-03, to be more precise),
+ ;; FFI::FOREIGN-LIBRARY-FUNCTION takes an additional
+ ;; 'PROPERTIES' argument.
+ #+#.(cl:if (cl:= (cl:length (ext:arglist
+ 'ffi::foreign-library-function)) 5)
+ '(and) '(or))
+ nil
+ (ffi:parse-c-type ',(c-function-type
+ types rettype calling-convention)))
+ (error (err)
+ (warn "~A" err))))
+ ,@fargs)))
+
+(defmacro %foreign-funcall-pointer (ptr args &key calling-convention)
"Similar to %foreign-funcall but takes a pointer instead of a string."
(multiple-value-bind (types fargs rettype)
(parse-foreign-funcall-args args)
- `(funcall (ffi:foreign-function ,ptr
- (load-time-value
- (ffi:parse-c-type
- '(ffi:c-function
- (:arguments ,@types)
- (:return-type ,rettype)
- (:language :stdc)))))
+ `(funcall (ffi:foreign-function
+ ,ptr (load-time-value
+ (ffi:parse-c-type ',(c-function-type
+ types rettype calling-convention))))
,@fargs)))
;;;# Callbacks
@@ -308,14 +323,14 @@ the function call."
;;; Return a CLISP FFI function type for a CFFI callback function
;;; given a return type and list of argument names and types.
(eval-when (:compile-toplevel :load-toplevel :execute)
- (defun callback-type (rettype arg-names arg-types)
+ (defun callback-type (rettype arg-names arg-types calling-convention)
(ffi:parse-c-type
`(ffi:c-function
(:arguments ,@(mapcar (lambda (sym type)
(list sym (convert-foreign-type type)))
arg-names arg-types))
(:return-type ,(convert-foreign-type rettype))
- (:language :stdc)))))
+ (:language ,(convert-cconv calling-convention))))))
;;; Register and create a callback function.
(defun register-callback (name function parsed-type)
@@ -344,9 +359,11 @@ the function call."
;;; ARG-NAMES translated according to ARG-TYPES and the return type
;;; translated according to RETTYPE. Obtain a pointer that can be
;;; passed to C code for this callback by calling %CALLBACK.
-(defmacro %defcallback (name rettype arg-names arg-types &body body)
- `(register-callback ',name (lambda ,arg-names ,@body)
- ,(callback-type rettype arg-names arg-types)))
+(defmacro %defcallback (name rettype arg-names arg-types body
+ &key calling-convention)
+ `(register-callback ',name (lambda ,arg-names ,body)
+ ,(callback-type rettype arg-names arg-types
+ calling-convention)))
;;; Look up the name of a callback and return a pointer that can be
;;; passed to a C function. Signals an error if no callback is
@@ -359,25 +376,26 @@ the function call."
;;;# Loading and Closing Foreign Libraries
-(defun %load-foreign-library (name)
- "Load a foreign library from NAME."
- (ffi::foreign-library name))
+(defun %load-foreign-library (name path)
+ "Load a foreign library from PATH."
+ (declare (ignore name))
+ (ffi::foreign-library path))
-(defun %close-foreign-library (name)
- "Close a foreign library NAME."
- (ffi:close-foreign-library name))
+(defun %close-foreign-library (handle)
+ "Close a foreign library."
+ (ffi:close-foreign-library handle))
(defun native-namestring (pathname)
(namestring pathname))
;;;# Foreign Globals
-(defun foreign-symbol-pointer (name)
+(defun %foreign-symbol-pointer (name library)
"Returns a pointer to a foreign symbol NAME."
(prog1 (ignore-errors
(ffi:foreign-address
(ffi::foreign-library-variable
- name (ffi::foreign-library :default) nil nil)))))
+ name library nil nil)))))
;;;# Finalizers
Oops, something went wrong.

0 comments on commit 4f37c6d

Please sign in to comment.