From 5b2a69c7ed75fbb307bc2c5d0f87807a4448c6b8 Mon Sep 17 00:00:00 2001 From: Juan Jose Garcia Ripoll Date: Mon, 26 Apr 2010 14:17:47 +0200 Subject: [PATCH] Move FOREIGN-ELT-TYPE-P into ffi.d, because the list of types in ffi.lsp had become obsolete and difficult to maintain. --- src/c/ffi.d | 39 ++++++++++++++++++++++++++++++++++----- src/c/symbols_list.h | 2 ++ src/c/symbols_list2.h | 2 ++ src/h/external.h | 2 ++ src/lsp/ffi.lsp | 15 ++------------- 5 files changed, 42 insertions(+), 18 deletions(-) diff --git a/src/c/ffi.d b/src/c/ffi.d index 48431999c..ea5ba8476 100644 --- a/src/c/ffi.d +++ b/src/c/ffi.d @@ -333,6 +333,20 @@ si_foreign_data_tag(cl_object f) @(return f->foreign.tag); } +cl_object +si_foreign_data_equal(cl_object f1, cl_object f2) +{ + if (ecl_unlikely(!ECL_FOREIGN_DATA_P(f1))) { + FEwrong_type_only_arg(@[si::foreign-data-address], f1, + @[si::foreign-data]); + } + if (ecl_unlikely(!ECL_FOREIGN_DATA_P(f2))) { + FEwrong_type_only_arg(@[si::foreign-data-address], f2, + @[si::foreign-data]); + } + @(return ((f1->foreign.data == f2->foreign.data)? Ct : Cnil)) +} + cl_object si_foreign_data_pointer(cl_object f, cl_object andx, cl_object asize, cl_object tag) @@ -397,16 +411,25 @@ si_foreign_data_set(cl_object f, cl_object andx, cl_object value) @(return value) } -enum ecl_ffi_tag -ecl_foreign_type_code(cl_object type) +static int +foreign_type_code(cl_object type) { int i; for (i = 0; i <= ECL_FFI_VOID; i++) { if (type == ecl_foreign_type_table[i]) - return (enum ecl_ffi_tag)i; + return i; } - FEerror("~A does not denote an elementary foreign type.", 1, type); - return ECL_FFI_VOID; + return -1; +} + +enum ecl_ffi_tag +ecl_foreign_type_code(cl_object type) +{ + int i = foreign_type_code(type); + if (ecl_unlikely(i < 0)) { + FEerror("~A does not denote an elementary foreign type.", 1, type); + } + return (enum ecl_ffi_tag)i; } #ifdef HAVE_LIBFFI @@ -630,6 +653,12 @@ si_size_of_foreign_elt_type(cl_object type) @(return MAKE_FIXNUM(ecl_foreign_type_size[tag])) } +cl_object +si_foreign_elt_type_p(cl_object type) +{ + @(return ((foreign_type_code(type) < 0)? Cnil : Ct)) +} + cl_object si_null_pointer_p(cl_object f) { diff --git a/src/c/symbols_list.h b/src/c/symbols_list.h index d41ca2c28..1fb22664d 100755 --- a/src/c/symbols_list.h +++ b/src/c/symbols_list.h @@ -1400,6 +1400,7 @@ cl_symbols[] = { {SYS_ "FIND-FOREIGN-SYMBOL", 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-EQUAL", SI_ORDINARY, si_foreign_data_equal, 2, OBJNULL}, {SYS_ "FOREIGN-DATA-P", SI_ORDINARY, si_foreign_data_p, 1, OBJNULL}, {SYS_ "FOREIGN-DATA-POINTER", SI_ORDINARY, si_foreign_data_pointer, 4, OBJNULL}, {SYS_ "FOREIGN-DATA-RECAST", SI_ORDINARY, si_foreign_data_recast, 3, OBJNULL}, @@ -1408,6 +1409,7 @@ cl_symbols[] = { {SYS_ "FOREIGN-DATA-SET", SI_ORDINARY, si_foreign_data_set, 3, OBJNULL}, {SYS_ "FOREIGN-DATA-SET-ELT", SI_ORDINARY, si_foreign_data_set_elt, 4, OBJNULL}, {SYS_ "FOREIGN-DATA-TAG", SI_ORDINARY, si_foreign_data_tag, 1, OBJNULL}, +{SYS_ "FOREIGN-ELT-TYPE-P", SI_ORDINARY, si_foreign_elt_type_p, 1, OBJNULL}, {SYS_ "FREE-FOREIGN-DATA", SI_ORDINARY, si_free_foreign_data, 1, OBJNULL}, {SYS_ "MAKE-FOREIGN-DATA-FROM-ARRAY", SI_ORDINARY, si_make_foreign_data_from_array, 1, OBJNULL}, {SYS_ "LOAD-FOREIGN-MODULE", SI_ORDINARY, si_load_foreign_module, 1, OBJNULL}, diff --git a/src/c/symbols_list2.h b/src/c/symbols_list2.h index 1f2588060..46d9f890f 100755 --- a/src/c/symbols_list2.h +++ b/src/c/symbols_list2.h @@ -1400,6 +1400,7 @@ cl_symbols[] = { {SYS_ "FIND-FOREIGN-SYMBOL","si_find_foreign_symbol"}, {SYS_ "FOREIGN-DATA",NULL}, {SYS_ "FOREIGN-DATA-ADDRESS","si_foreign_data_address"}, +{SYS_ "FOREIGN-DATA-EQUAL","si_foreign_data_equal"}, {SYS_ "FOREIGN-DATA-P","si_foreign_data_p"}, {SYS_ "FOREIGN-DATA-POINTER","si_foreign_data_pointer"}, {SYS_ "FOREIGN-DATA-RECAST","si_foreign_data_recast"}, @@ -1408,6 +1409,7 @@ cl_symbols[] = { {SYS_ "FOREIGN-DATA-SET","si_foreign_data_set"}, {SYS_ "FOREIGN-DATA-SET-ELT","si_foreign_data_set_elt"}, {SYS_ "FOREIGN-DATA-TAG","si_foreign_data_tag"}, +{SYS_ "FOREIGN-ELT-TYPE-P","si_foreign_elt_type_p"}, {SYS_ "FREE-FOREIGN-DATA","si_free_foreign_data"}, {SYS_ "MAKE-FOREIGN-DATA-FROM-ARRAY","si_make_foreign_data_from_array"}, {SYS_ "LOAD-FOREIGN-MODULE","si_load_foreign_module"}, diff --git a/src/h/external.h b/src/h/external.h index 3614c6da3..915f1e23b 100755 --- a/src/h/external.h +++ b/src/h/external.h @@ -590,8 +590,10 @@ extern ECL_API cl_object _ecl_link_call(cl_object sym, cl_objectfn *pLK, cl_obje /* ffi.c */ extern ECL_API cl_object si_allocate_foreign_data(cl_object tag, cl_object size); +extern ECL_API cl_object si_foreign_elt_type_p(cl_object f); extern ECL_API cl_object si_foreign_data_p(cl_object f); extern ECL_API cl_object si_foreign_data_address(cl_object f); +extern ECL_API cl_object si_foreign_data_equal(cl_object f1, cl_object f2); extern ECL_API cl_object si_foreign_data_pointer(cl_object f, cl_object ndx, cl_object size, cl_object tag); extern ECL_API cl_object si_foreign_data_ref(cl_object f, cl_object ndx, cl_object size, cl_object tag); extern ECL_API cl_object si_foreign_data_ref_elt(cl_object f, cl_object ndx, cl_object tag); diff --git a/src/lsp/ffi.lsp b/src/lsp/ffi.lsp index 890d17673..1a3074a21 100644 --- a/src/lsp/ffi.lsp +++ b/src/lsp/ffi.lsp @@ -36,7 +36,8 @@ "*USE-DFFI*" ) - (:import-from "SYS" "NULL-POINTER-P" "GET-SYSPROP" "PUT-SYSPROP")) + (:import-from "SYS" "NULL-POINTER-P" "GET-SYSPROP" "PUT-SYSPROP" + "FOREIGN-ELT-TYPE-P")) (in-package "FFI") @@ -58,18 +59,6 @@ (defvar *use-dffi* t) -(defun foreign-elt-type-p (name) - (and (symbolp name) - (member name '(:byte :unsigned-byte :short :unsigned-short - :int :unsigned-int :char :unsigned-char - :long :unsigned-long :pointer-void :object - :float :double :cstring - :int8-t #+uint16-t :int16-t - #+uint32-t :int32-t #+uint64-t :int64-t - :uint8-t #+uint16-t :uint16-t - #+uint32-t :uint32-t #+uint64-t :uint64-t) - :test 'eq))) - (defmacro def-foreign-type (name definition) `(eval-when (:compile-toplevel :load-toplevel :execute) (setf (gethash ',name ffi::*ffi-types*) ',definition)))