2008-03-13 Kaz Kylheku Support for versioned symbols in FFI. An unversioned name continues to be represented by a simple string. A versioned name is denoted by a cons pairs of strings. The lookup for a versioned name is done through dlvsym. * foreign.d (coerce_ss_name): New function. (foreign_function, find_foreign_variable, foreign_variable, find_foreign_function): Call coerce_ss_name instead of coerce_ss. (find_versioned_name): New function. (object_handle): Check for the new cons form of the name, and look up a versioned symbol through find_versioned_name. * foreign1.lisp (parse-foreign-name): Revised to allow cons representation of names. * m4/dynload.m4 (CL_DYNLOAD): Add dlvsym to list of functions to detect. Index: clisp/src/foreign.d =================================================================== --- clisp.orig/src/foreign.d 2008-03-13 12:53:53.624299000 -0800 +++ clisp/src/foreign.d 2008-03-13 12:54:27.997402000 -0800 @@ -666,6 +666,35 @@ return fa; } +/* Coerce: string -> simple-string + (string . string) -> (simple-string . simple-string) */ +local maygc object coerce_ss_name(object name) +{ + if (consp(name)) { + pushSTACK(name); + pushSTACK(coerce_ss(Car(STACK_0))); + pushSTACK(coerce_ss(Cdr(STACK_1))); + + /* STACK_2 == name + * STACK_1 == coerce_ss(car(name)) + * STACK_0 == coerce_ss(cdr(name)) + */ + if (eq(Car(STACK_2), STACK_1) && eq(Cdr(STACK_2), STACK_0)) { + /* If coerce_ss did nothing, return original name */ + skipSTACK(2); + return popSTACK(); + } + + var object cons = allocate_cons(); + Cdr(cons) = popSTACK(); + Car(cons) = popSTACK(); + skipSTACK(1); + return cons; + } else { + return coerce_ss(name); + } +} + /* (FFI:FOREIGN-FUNCTION address c-type &key name) constructor */ LISPFUN(foreign_function,seclass_read,2,0,norest,key,1,(kw(name)) ) { @@ -698,7 +727,7 @@ /* TODO need to visit callback interaction */ if (nullp(TheFfunction(ff)->ff_name) && !missingp(STACK_0)) { pushSTACK(ff); - STACK_1 = coerce_ss(STACK_1); + STACK_1 = coerce_ss_name(STACK_1); ff = popSTACK(); TheFfunction(ff)->ff_name = STACK_0; } @@ -2490,7 +2519,7 @@ /* (FFI::FIND-FOREIGN-VARIABLE foreign-variable-name foreign-type foreign-library foreign-offset) */ LISPFUNN(find_foreign_variable,4) { - STACK_3 = coerce_ss(STACK_3); + STACK_3 = coerce_ss_name(STACK_3); VALUES1(nullp(STACK_1) ? lookup_foreign_variable(&STACK_3,&STACK_2) : foreign_library_variable(&STACK_3,&STACK_2,&STACK_1,&STACK_0)); skipSTACK(4); @@ -2516,7 +2545,7 @@ goto foreign_variable_restart; } fa = check_faddress_valid(fa); - if (!missingp(STACK_0)) STACK_0 = coerce_ss(STACK_0); + if (!missingp(STACK_0)) STACK_0 = coerce_ss_name(STACK_0); var object fvar = allocate_fvariable(); var object fvd = STACK_1; var struct foreign_layout sas; @@ -3227,7 +3256,7 @@ /* (FFI::FIND-FOREIGN-FUNCTION foreign-function-name foreign-type properties foreign-library foreign-offset) */ LISPFUNN(find_foreign_function,5) { - STACK_4 = coerce_ss(STACK_4); + STACK_4 = coerce_ss_name(STACK_4); STACK_3 = check_foreign_function_type(STACK_3); VALUES1(nullp(STACK_1) ? lookup_foreign_function(&STACK_4,&STACK_3,&STACK_2) : foreign_library_function(&STACK_4,&STACK_3,&STACK_2, @@ -4224,6 +4253,20 @@ mark_fp_invalid(TheFpointer(fp)); } +/* find versioned symbol in the dynamic library. + If this functionality is not supported, then the symbol + is not found, even if the name does exist in the library. */ +local void* find_versioned_name (void *handle, const char *name, + const char *ver) { + var void *ret = NULL; +#ifdef HAVE_DLVSYM + ret = dlvsym(handle,name,ver); +#else + unused(ver); +#endif + return ret; +} + /* return the object handle > library - library specifier (lib addr obj...) > name - object name (string) @@ -4231,11 +4274,22 @@ can trigger GC */ local maygc void* object_handle (object library, object name) { var void * address; - with_string_0(name,O(foreign_encoding),namez, { - begin_system_call(); - address = find_name(TheFpointer(Car(Cdr(library)))->fp_pointer, namez); - end_system_call(); - }); + if (consp(name)) { + with_string_0(Car(name),O(foreign_encoding),namez, + with_string_0(Cdr(name),O(foreign_encoding),verz, { + begin_system_call(); + address = find_versioned_name(TheFpointer + (Car(Cdr(library)))->fp_pointer, + namez, verz); + end_system_call(); + });); + } else { + with_string_0(name,O(foreign_encoding),namez, { + begin_system_call(); + address = find_name(TheFpointer(Car(Cdr(library)))->fp_pointer, namez); + end_system_call(); + }); + } if (address == NULL) { pushSTACK(NIL); /* 5 continue-format-string */ pushSTACK(S(error)); /* 4 error type */ @@ -4438,7 +4492,7 @@ } /* UP: find and allocate a foreign variable in a dynamic library - > name - variable C name (string - prechecked) + > name - variable C name (string or (string . string) - prechecked) > library - library C name (string - checked here) > offset - address offset in the library or NIL > fvd - function type @@ -4467,7 +4521,7 @@ } /* UP: find and allocate a foreign function in a dynamic library - > name - function C name (string - prechecked) + > name - function C name (string or (string . string) - prechecked) > library - library C name (string - checked here) > offset - address offset in the library or NIL > properties - function properties Index: clisp/src/foreign1.lisp =================================================================== --- clisp.orig/src/foreign1.lisp 2008-03-13 12:53:53.645297000 -0800 +++ clisp/src/foreign1.lisp 2008-03-13 12:54:28.009402000 -0800 @@ -418,13 +418,19 @@ (setq *foreign-language* :STDC))))))))) ; Default is ANSI C (defun parse-foreign-name (name) - (unless (stringp name) - (error (TEXT "The name must be a string, not ~S") - name)) - (if (c-ident-p name) - name - (error (TEXT "The name ~S is not a valid C identifier") - name))) + (flet ((check-c (name) + (unless (c-ident-p name) + (error (TEXT "The name ~S is not a valid C identifier") + name)))) + (cond + ((stringp name) (check-c name) name) + ((and (consp name) + (stringp (car name)) + (stringp (cdr name))) + (check-c (car name)) name) + (t + (error (TEXT "The name must be a string or cons pair of strings, not ~S") + name))))) (defmacro DEF-C-TYPE (&whole whole-form name &optional typespec) (setq name (check-symbol name (first whole-form))) Index: clisp/doc/impext.xml =================================================================== --- clisp.orig/doc/impext.xml 2008-03-13 12:53:53.701305000 -0800 +++ clisp/doc/impext.xml 2008-03-13 12:54:28.048402000 -0800 @@ -2777,6 +2777,14 @@ Any Lisp function call to #'&name-r; is redirected to call the &c-lang; function &cname-r;. +(&name-k; (&cname-r; . &version-r;)) +A name specified as a cons pair of strings denotes + a versioned symbol. The first string is the symbol name, and the second is + the version string. This is useful on platforms that support shared libraries + with versioned symbols. A Lisp function call to + #'&name-r; will be redirected to call the + version of the &c-lang; function &cname-r; specified by &version-r;. + (&arguments-k; {(&arg-r; &ctype-r; [¶m-mode; [&allocation;]])}*) (&ret-type-k; &ctype-r; [&allocation;]) Index: clisp/doc/impent.xml =================================================================== --- clisp.orig/doc/impent.xml 2008-03-13 12:53:53.724302000 -0800 +++ clisp/doc/impent.xml 2008-03-13 12:54:28.061402000 -0800 @@ -807,6 +807,7 @@ value'> variable'> vector'> +version'> what'> window-stream'> x'> Index: clisp/src/m4/dynload.m4 =================================================================== --- clisp.orig/src/m4/dynload.m4 2008-03-13 12:53:53.000000000 -0800 +++ clisp/src/m4/dynload.m4 2008-03-13 12:54:47.776468000 -0800 @@ -15,6 +15,6 @@ AC_CHECK_HEADERS(dlfcn.h) if test "$ac_cv_header_dlfcn_h" = yes; then AC_SEARCH_LIBS(dlopen, dl) - AC_CHECK_FUNCS(dlopen dlsym dlerror dlclose dladdr) + AC_CHECK_FUNCS(dlopen dlsym dlvsym dlerror dlclose dladdr) fi ])