diff --git a/msvc/ecl-threads.def b/msvc/ecl-threads.def index a0cb27eac..f567c4a1d 100755 --- a/msvc/ecl-threads.def +++ b/msvc/ecl-threads.def @@ -261,6 +261,7 @@ EXPORTS ; ffi.c si_allocate_foreign_data + si_find_foreign_symbol si_foreign_data_address si_foreign_data_pointer si_foreign_data_ref diff --git a/msvc/ecl.def b/msvc/ecl.def index ac3dedcc1..8af9f546b 100644 --- a/msvc/ecl.def +++ b/msvc/ecl.def @@ -261,6 +261,7 @@ EXPORTS ; ffi.c si_allocate_foreign_data + si_find_foreign_symbol si_foreign_data_address si_foreign_data_pointer si_foreign_data_ref diff --git a/src/c/ffi.d b/src/c/ffi.d index d418fb68b..44fe79db0 100644 --- a/src/c/ffi.d +++ b/src/c/ffi.d @@ -361,3 +361,51 @@ si_foreign_data_recast(cl_object f, cl_object size, cl_object tag) f->foreign.tag = tag; @(return f) } + +cl_object +ecl_library_get_or_open(cl_object filename) +{ + cl_object libraries = cl_core.libraries; + int i; + + for (i=0; ivector.fillp; i++) + if (cl_stringE(2, libraries->vector.self.t[i]->cblock.name, filename) != Cnil) + return libraries->vector.self.t[i]; + + return ecl_library_open(filename); +} + +cl_object +si_find_foreign_symbol(cl_object var, cl_object module, cl_object type, cl_object size) +{ + cl_object block; + cl_object output; + void *sym; + +#ifdef ECL_THREADS + mp_get_lock(1, symbol_value(@'mp::+load-compile-lock+')); + CL_UNWIND_PROTECT_BEGIN { +#endif + block = ecl_library_get_or_open(module); + if (block->cblock.handle == NULL) { + output = ecl_library_error(block); + goto OUTPUT; + } + sym = ecl_library_symbol(block, ecl_string_pointer_safe(var)); + if (sym == NULL) { + output = ecl_library_error(block); + goto OUTPUT; + } + output = ecl_make_foreign_data(type, object_to_fixnum(size), sym); +OUTPUT: +#ifdef ECL_THREADS + (void)0; /* MSVC complains about missing ';' before '}' */ + } CL_UNWIND_PROTECT_EXIT { + mp_giveup_lock(symbol_value(@'mp::+load-compile-lock+')); + } CL_UNWIND_PROTECT_END; +#endif + if (type_of(output) == t_foreign) + @(return output) + else + FEerror("FIND-FOREIGN-VAR: Could not load foreign variable ~S from modeul ~S (Error: ~S)", 3, var, module, output); +} diff --git a/src/c/symbols_list.h b/src/c/symbols_list.h index 7c0db9342..e49e047a1 100644 --- a/src/c/symbols_list.h +++ b/src/c/symbols_list.h @@ -1429,6 +1429,7 @@ cl_symbols[] = { #endif {SYS_ "ALLOCATE-FOREIGN-DATA", SI_ORDINARY, si_allocate_foreign_data, 2, OBJNULL}, +{SYS_ "FIND-FOREIGN-VAR", SI_ORDINARY, si_find_foreign_symbol, 4, OBJNULL}, {SYS_ "FOREIGN-DATA", SI_ORDINARY, NULL, -1, OBJNULL}, {SYS_ "FOREIGN-DATA-ADDRESS", SI_ORDINARY, si_foreign_data_address, 1, OBJNULL}, {SYS_ "FOREIGN-DATA-POINTER", SI_ORDINARY, si_foreign_data_pointer, 4, OBJNULL}, diff --git a/src/c/symbols_list2.h b/src/c/symbols_list2.h index ce38d8405..31df03738 100644 --- a/src/c/symbols_list2.h +++ b/src/c/symbols_list2.h @@ -1429,6 +1429,7 @@ cl_symbols[] = { #endif {SYS_ "ALLOCATE-FOREIGN-DATA","si_allocate_foreign_data"}, +{SYS_ "FIND-FOREIGN-VAR","si_find_foreign_symbol"}, {SYS_ "FOREIGN-DATA",NULL}, {SYS_ "FOREIGN-DATA-ADDRESS","si_foreign_data_address"}, {SYS_ "FOREIGN-DATA-POINTER","si_foreign_data_pointer"}, diff --git a/src/h/external.h b/src/h/external.h index 9509853ef..34c07abb6 100644 --- a/src/h/external.h +++ b/src/h/external.h @@ -503,6 +503,7 @@ extern cl_object si_foreign_data_recast(cl_object f, cl_object size, cl_object t extern cl_object si_free_foreign_data(cl_object x); extern cl_object si_null_pointer_p(cl_object f); extern cl_object si_size_of_foreign_elt_type(cl_object tag); +extern cl_object si_find_foreign_symbol(cl_object var, cl_object module, cl_object type, cl_object size); extern cl_object ecl_make_foreign_data(cl_object tag, cl_index size, void *data); extern cl_object ecl_allocate_foreign_data(cl_object tag, cl_index size); diff --git a/src/lsp/ffi.lsp b/src/lsp/ffi.lsp index 9aee273d8..2ba8d410d 100644 --- a/src/lsp/ffi.lsp +++ b/src/lsp/ffi.lsp @@ -509,6 +509,9 @@ 0 (max 0 (1- (* nargs 3)))))) (defmacro def-function (name args &key module (returning :void)) + (cond ((and module (macro-function (find-symbol "DEF-LIB-FUNCTION" "FFI"))) + `(def-lib-function ,name ,args :returning ,returning :module ,module)) + (t (multiple-value-bind (c-name lisp-name) (lisp-to-c-name name) (let* ((arguments (mapcar #'first args)) @@ -532,31 +535,31 @@ (error "FFI can only handle C functions with up to 36 arguments")) `(defun ,lisp-name (,@arguments) ,inline-form) - ))) + ))))) (defmacro def-foreign-var (name type module) - (declare (ignore module)) + ;(declare (ignore module)) (multiple-value-bind (c-name lisp-name) (lisp-to-c-name name) (let* ((ffi-type (%convert-to-ffi-type type)) (can-deref (or (foreign-elt-type-p ffi-type) (and (consp ffi-type) - (member (first ffi-type) '(* :array)))))) + (member (first ffi-type) '(* :array))))) + (inline-form (cond (module + `(si::find-foreign-var ,c-name ,module ,type ,(size-of-foreign-type type))) + (t + `(c-inline () () :object + ,(format nil "ecl_make_foreign_data(@~S, ~A, &~A)" + type (size-of-foreign-type type) c-name) + :side-effects t :one-liner t))))) (if can-deref `(progn - (put-sysprop ',lisp-name 'ffi-foreign-var - (c-inline () () :object - ,(format nil "ecl_make_foreign_data(@~S, ~A, &~A)" - type (size-of-foreign-type type) c-name) - :side-effects t :one-liner t)) + (put-sysprop ',lisp-name 'ffi-foreign-var ,inline-form) (eval-when (:compile-toplevel :load-toplevel :execute) (define-symbol-macro ,lisp-name (ffi:deref-pointer (get-sysprop ',lisp-name 'ffi-foreign-var) ',type) ))) - `(defvar ,lisp-name (c-inline () () :object - ,(format nil "ecl_make_foreign_data(@~S, ~A, &~A)" - type (size-of-foreign-type type) c-name) - :side-effects t :one-liner t))) + `(defvar ,lisp-name ,inline-form)) ))) (defun find-foreign-library (names directories &key drive-letters types)