~ chicken-core (chicken-5) 6eb407278bec522566490694924fafc4d3074646
commit 6eb407278bec522566490694924fafc4d3074646
Author: Felix <bunny351@gmail.com>
AuthorDate: Sat Oct 10 23:48:18 2009 +0200
Commit: Felix <bunny351@gmail.com>
CommitDate: Sat Oct 10 23:48:18 2009 +0200
reverted several commits that added dloaded module introspection and API; heavy
modifications where made to code that worked fine, and which nobody
complained about. To avoid wasting time on tracking down bugs in this code,
I have removed the changes.
diff --git a/chicken.h b/chicken.h
index 11b6a2c3..9f09e980 100644
--- a/chicken.h
+++ b/chicken.h
@@ -1506,7 +1506,6 @@ C_fctexport void C_ccall C_software_version(C_word c, C_word closure, C_word k)
C_fctexport void C_ccall C_build_platform(C_word c, C_word closure, C_word k) C_noret;
C_fctexport void C_ccall C_c_runtime(C_word c, C_word closure, C_word k) C_noret;
C_fctexport void C_ccall C_register_finalizer(C_word c, C_word closure, C_word k, C_word x, C_word proc) C_noret;
-C_fctexport void C_ccall C_dlopen_flags(C_word c, C_word closure, C_word k) C_noret;
C_fctexport void C_ccall C_set_dlopen_flags(C_word c, C_word closure, C_word k, C_word now, C_word global) C_noret;
C_fctexport void C_ccall C_dload(C_word c, C_word closure, C_word k, C_word name, C_word entry, C_word reloadable) C_noret;
C_fctexport void C_ccall C_become(C_word c, C_word closure, C_word k, C_word table) C_noret;
@@ -1515,15 +1514,6 @@ C_fctexport void C_ccall C_locative_ref(C_word c, C_word closure, C_word k, C_wo
C_fctexport void C_ccall C_call_with_cthulhu(C_word c, C_word self, C_word k, C_word proc) C_noret;
C_fctexport void C_ccall C_copy_closure(C_word c, C_word closure, C_word k, C_word proc) C_noret;
-C_fctexport void C_ccall C_dynamic_library_names(C_word c, C_word closure, C_word k) C_noret;
-C_fctexport void C_ccall C_dynamic_library_data(C_word c, C_word closure, C_word k, C_word libnam) C_noret;
-C_fctexport void C_ccall C_chicken_library_literal_frame(C_word c, C_word closure, C_word k, C_word lfnam, C_word lfhnd, C_word lfcnt) C_noret;
-C_fctexport void C_ccall C_chicken_library_ptable(C_word c, C_word closure, C_word k, C_word lfnam, C_word lfhnd, C_word lfcnt, C_word inclptrs) C_noret;
-
-C_fctexport void C_ccall C_dynamic_library_load(C_word c, C_word closure, C_word k, C_word name) C_noret;
-C_fctexport void C_ccall C_dynamic_library_symbol(C_word c, C_word closure, C_word k, C_word mname, C_word sname, C_word isprcsym) C_noret;
-C_fctexport void C_ccall C_dynamic_library_unload(C_word c, C_word closure, C_word k, C_word name) C_noret;
-
#if !defined(__GNUC__) && !defined(__INTEL_COMPILER)
C_fctexport C_word *C_a_i(C_word **a, int n);
#endif
@@ -1670,16 +1660,9 @@ C_fctexport C_word C_fcall C_i_foreign_scheme_or_c_pointer_argumentp(C_word x) C
C_fctexport C_word C_fcall C_i_foreign_integer_argumentp(C_word x) C_regparm;
C_fctexport C_word C_fcall C_i_foreign_unsigned_integer_argumentp(C_word x) C_regparm;
-C_fctexport void * C_fcall C_dynamic_library_open(C_char *name) C_regparm;
-C_fctexport void * C_fcall C_dynamic_library_procedure(void *handle, C_char *name) C_regparm;
-C_fctexport void * C_fcall C_dynamic_library_procedure_exact(void *handle, C_char *name) C_regparm;
-C_fctexport void * C_fcall C_dynamic_library_variable(void *handle, C_char *name) C_regparm;
-C_fctexport void * C_fcall C_dynamic_library_variable_exact(void *handle, C_char *name) C_regparm;
-C_fctexport int C_fcall C_dynamic_library_close(void *handle) C_regparm;
-
-C_fctexport C_char * C_lookup_procedure_id(void *ptr);
-C_fctexport void * C_lookup_procedure_ptr(C_char *id);
-C_fctexport C_word C_ccall C_dunload(C_word name);
+C_fctexport C_char *C_lookup_procedure_id(void *ptr);
+C_fctexport void *C_lookup_procedure_ptr(C_char *id);
+C_fctexport C_word C_dunload(C_word name);
#ifdef C_SIXTY_FOUR
C_fctexport void C_ccall C_peek_signed_integer_32(C_word c, C_word closure, C_word k, C_word v, C_word index) C_noret;
diff --git a/chicken.import.scm b/chicken.import.scm
index 9db915a9..61bef7d8 100644
--- a/chicken.import.scm
+++ b/chicken.import.scm
@@ -205,12 +205,6 @@
warning
eval-handler
er-macro-transformer
- set-dynamic-load-mode! ;DEPRECATED
- dynamic-load-mode
dynamic-load-libraries
- loaded-libraries
- dynamic-library-load
- dynamic-library-procedure
- dynamic-library-variable
with-exception-handler)
##sys#chicken-macro-environment) ;*** incorrect - won't work in compiled executable that does expansion
diff --git a/eval.scm b/eval.scm
index 82078202..1e91db10 100644
--- a/eval.scm
+++ b/eval.scm
@@ -27,9 +27,10 @@
(declare
(unit eval)
- (uses expand data-structures)
+ (uses expand)
(disable-warning var)
- (hide ##sys#r4rs-environment ##sys#r5rs-environment
+ (hide ##sys#split-at-separator
+ ##sys#r4rs-environment ##sys#r5rs-environment
##sys#interaction-environment pds pdss pxss)
(not inline ##sys#repl-eval-hook ##sys#repl-read-hook ##sys#repl-print-hook
##sys#read-prompt-hook ##sys#alias-global-hook ##sys#user-read-hook
@@ -873,40 +874,20 @@
(define-foreign-variable _dlerror c-string "C_dlerror")
-(define dynamic-load-mode)
-(define set-dynamic-load-mode!) ;DEPRECATED
-(let ()
-
- (define (dynamic-load-flags->mode flags)
- (and flags
- (list (if (car flags) 'now 'lazy) (if (cadr flags) 'global 'local)) ) )
-
- (define (dynamic-load-mode->flags mode)
- (let ((mode (if (pair? mode) mode (list mode)))
- (now #f)
- (global #t) )
- (let loop ((mode mode))
- (when (pair? mode)
- (case (car mode)
- ((global) (set! global #t))
- ((local) (set! global #f))
- ((lazy) (set! now #f))
- ((now) (set! now #t))
- (else
- (##sys#signal-hook 'set-dynamic-load-mode! "invalid dynamic-load mode" (car mode)) ) )
- (loop (cdr mode)) ) )
- (list now global) ) )
-
- (set! dynamic-load-mode
- (make-parameter (dynamic-load-flags->mode (##sys#dlopen-flags))
- (lambda (x)
- (cond ((or (pair? x) (symbol? x))
- (apply ##sys#set-dlopen-flags! (dynamic-load-mode->flags x))
- (dynamic-load-flags->mode (##sys#dlopen-flags)) )
- (else
- '(lazy global) ) ) ) ) )
-
- (set! set-dynamic-load-mode! (lambda (mode) (dynamic-load-mode mode) ) ) )
+(define (set-dynamic-load-mode! mode)
+ (let ([mode (if (pair? mode) mode (list mode))]
+ [now #f]
+ [global #t] )
+ (let loop ([mode mode])
+ (when (pair? mode)
+ (case (##sys#slot mode 0)
+ [(global) (set! global #t)]
+ [(local) (set! global #f)]
+ [(lazy) (set! now #f)]
+ [(now) (set! now #t)]
+ [else (##sys#signal-hook 'set-dynamic-load-mode! "invalid dynamic-load mode" (##sys#slot mode 0))] )
+ (loop (##sys#slot mode 1)) ) )
+ (##sys#set-dlopen-flags! now global) ) )
(let ([read read]
[write write]
@@ -1052,8 +1033,7 @@
(let ([libs
(if lib
(##sys#list lib)
- (cons (##sys#string-append (##sys#slot uname 1) ;symbol pname
- ##sys#load-library-extension)
+ (cons (##sys#string-append (##sys#slot uname 1) ##sys#load-library-extension)
(dynamic-load-libraries) ) ) ]
[top
(##sys#make-c-string
@@ -1068,9 +1048,7 @@
(let loop ([libs libs])
(cond [(null? libs) #f]
[(##sys#dload (##sys#make-c-string (##sys#slot libs 0)) top #f)
- ; Cannot be in features yet but check anyway
- (unless (memq id ##sys#features)
- (set! ##sys#features (cons id ##sys#features)) )
+ (unless (memq id ##sys#features) (set! ##sys#features (cons id ##sys#features)))
#t]
[else (loop (##sys#slot libs 1))] ) ) ) ) ) ) ) )
@@ -1082,59 +1060,17 @@
(define load-library ##sys#load-library)
-(define (loaded-libraries)
- ; Ignore the names of explicitly loaded library units
- (let loop ((ils (##sys#dynamic-library-names)) (ols '()))
- (if (null? ils)
- ols
- (let ((nam (car ils)))
- (loop (cdr ils) (if (member nam (dynamic-load-libraries)) ols (cons nam ols))) ) ) ) )
-
-(define (dynamic-library-load name #!optional (err? #t))
- (##sys#check-string name 'dynamic-library-load)
- (or (##sys#dynamic-library-load name)
- (and err?
- (##sys#error 'dynamic-library-load "cannot load dynamic library" name _dlerror) ) ) )
-
-;; (dynamic-library-procedure mname sname handler [error?]) => procedure/n
-;; (dynamic-library-variable mname sname handler [error?]) => procedure/n
-;;
-;; The 'procedure/n' invokes the handler on (mname sname mname+sname-ptr n-args).
-;; A symbol 'sname' is converted to a string.
-;;
-;; Will attempt to load (global lazy) the library should the attempt to
-;; resolve the symbol fail. Either this succeeds and the symbol is then
-;; resolved, or an error will be signaled.
-
-(define dynamic-library-procedure)
-(define dynamic-library-variable)
-(let ()
-
- (define (checked-pointer loc ptrfnc mname sname err?)
- (or (ptrfnc mname sname)
- (and (parameterize ((dynamic-load-mode '(lazy global)))
- (dynamic-library-load mname err?))
- (ptrfnc mname sname) )
- (and err?
- (##sys#error loc "cannot resolve dynamic library symbol" mname sname _dlerror) ) ) )
-
- (define (dynlibsym loc ptrfnc mname sname handler err?)
- (##sys#check-string mname loc)
- (##sys#check-closure handler loc)
- (let ((sname (if (symbol? sname) (symbol->string sname) sname)))
- (##sys#check-string sname loc)
- (and-let* ((ptr (checked-pointer loc ptrfnc mname sname err?)))
- (lambda args (handler mname sname ptr args)) ) ) )
-
- (set! dynamic-library-procedure
- (lambda (mname sname handler #!optional (err? #t))
- (dynlibsym 'dynamic-library-procedure
- ##sys#dynamic-library-procedure-pointer mname sname handler err?) ) )
-
- (set! dynamic-library-variable
- (lambda (mname sname handler #!optional (err? #t))
- (dynlibsym 'dynamic-library-variable
- ##sys#dynamic-library-variable-pointer mname sname handler err?) ) ) )
+(define ##sys#split-at-separator
+ (let ([reverse reverse] )
+ (lambda (str sep)
+ (let ([len (##sys#size str)])
+ (let loop ([items '()] [i 0] [j 0])
+ (cond [(fx>= i len)
+ (reverse (cons (##sys#substring str j len) items)) ]
+ [(char=? (##core#inline "C_subchar" str i) sep)
+ (let ([i2 (fx+ i 1)])
+ (loop (cons (##sys#substring str j i) items) i2 i2) ) ]
+ [else (loop items (fx+ i 1) j)] ) ) ) ) ) )
;;; Extensions:
diff --git a/library.scm b/library.scm
index c364a87c..d29eb6ca 100644
--- a/library.scm
+++ b/library.scm
@@ -364,63 +364,15 @@ EOF
;;; Dynamic Load
-;; Library load mode (only active when HAVE_DLFCN_H at the momemnt)
-
-(define ##sys#dlopen-flags (##core#primitive "C_dlopen_flags"))
-(define ##sys#set-dlopen-flags! (##core#primitive "C_set_dlopen_flags"))
-
-;; Chicken library load
-
(define ##sys#dload (##core#primitive "C_dload"))
+(define ##sys#set-dlopen-flags! (##core#primitive "C_set_dlopen_flags"))
-; Dynamic Unload not available on all platforms and to be used with caution!
+;; Dynamic Unload not available on all platforms and to be used with caution!
(define (##sys#dunload name)
- (and-let* (((##core#inline "C_dunload" (##sys#make-c-string name))))
+ (and-let* ((r (##core#inline "C_dunload" (##sys#make-c-string name))))
(##sys#gc #t)
#t ) )
-;; Non-Chicken library load
-
-(define ##sys#dynamic-library-load (##core#primitive "C_dynamic_library_load"))
-
-; Dynamic Unload not available on all platforms and to be used with caution!
-(define ##sys#dynamic-library-unload (##core#primitive "C_dynamic_library_unload"))
-
-;; Introspection of loaded libraries
-
-; (##sys#dynamic-library-procedure-pointer mname sname) => mname+sname-ptr or #f
-; (##sys#dynamic-library-variable-pointer mname sname) => mname+sname-ptr or #f
-
-(define (##sys#dynamic-library-procedure-pointer mname sname)
- ((##core#primitive "C_dynamic_library_symbol") mname sname #t) )
-
-(define (##sys#dynamic-library-variable-pointer mname sname)
- ((##core#primitive "C_dynamic_library_symbol") mname sname #f) )
-
-; (##sys#dynamic-library-names) => (<pathname>...)
-; Does not return the "name" of the running program (i.e. #f) but
-; does return any default libraries.
-
-(define ##sys#dynamic-library-names (##core#primitive "C_dynamic_library_names"))
-
-; (##sys#dynamic-library-data name)
-; => ((<dload-handle> <literal-frame-count> <ptable?>)...)
-; <dload-handle> is a pointer to the actual dload handle or #f
-; <literal-frame-count> is the total of entrypoints (toplevel)
-; <ptable?> is a boolean indicating whether the lib has a ptable
-
-(define ##sys#dynamic-library-data (##core#primitive "C_dynamic_library_data"))
-
-; (##sys#chicken-library-literal-frame name handle count) => (<lf[0]>...)
-
-(define ##sys#chicken-library-literal-frame (##core#primitive "C_chicken_library_literal_frame"))
-
-; (##sys#chicken-library-ptable name handle count pointer?)
-; => ((<ptable[0].id> . <ptable[0].ptr>)...) when pointer?
-; => (<ptable[0].id>...) when (not pointer?)
-
-(define ##sys#chicken-library-ptable (##core#primitive "C_chicken_library_ptable"))
-
;;; Operations on booleans:
diff --git a/manual/Parameters b/manual/Parameters
index e6343bc0..b1c7d7c5 100644
--- a/manual/Parameters
+++ b/manual/Parameters
@@ -59,6 +59,7 @@ the program and any runtime options (all options starting with {{-:}})
removed.
+
=== current-read-table
A read-table object that holds read-procedures for special non-standard
read-syntax (see {{set-read-syntax!}} for more information).
@@ -129,21 +130,6 @@ default behavior in compiled code is to invoke the value of
{{(exit-handler)}}. The default behavior in the interpreter is to
abort the current computation and to restart the read-eval-print loop.
-
-=== dynamic-load-mode
-On systems that support dynamic loading of compiled code via the {{dlopen(3)}}
-interface (for example Linux and Solaris), some options can be specified to
-fine-tune the behaviour of the dynamic linker. {{MODE}} should be a list of
-symbols (or a single symbol) taken from the following set:
-
-; {{local}} : If {{local}} is given, then any C/C++ symbols defined in the dynamically loaded file are not available for subsequently loaded files and libraries. Use this if you have linked foreign code into your dynamically loadable file and if you don't want to export them (for example because you want to load another file that defines the same symbols).
-; {{global}} : The default is {{global}}, which means all C/C++ symbols are available to code loaded at a later stage.
-; {{now}} : If {{now}} is specified, all symbols are resolved immediately.
-; {{lazy}} : Unresolved symbols are resolved as code from the file is executed. This is the default.
-
-Note that this procedure does not control the way Scheme variables are handled -
-this facility is mainly of interest when accessing foreign code.
-
---
Previous: [[Declarations]]
diff --git a/manual/Unit eval b/manual/Unit eval
index 4aa1e7c9..aa109554 100644
--- a/manual/Unit eval
+++ b/manual/Unit eval
@@ -61,7 +61,6 @@ printed before evaluation by applying the expression to the value of this
argument, which should be a one-argument procedure.
See also the [[http://chicken.wiki.br/Parameters#load-verbose|load-verbose]] parameter.
-
==== load-library
[procedure] (load-library UNIT [LIBRARYFILE])
@@ -81,68 +80,6 @@ can be successfully loaded, a feature-identifier named {{UNIT}}
is registered. If the feature is already registered before loading,
the {{load-library}} does nothing.
-==== loaded-libraries
-
- [procedure] (loaded-libraries)
-
-Returns a list of the dynamic library names.
-
-==== dynamic-library-load
-
- [procedure] (dynamic-library-load LIBRARYFILE [ERROR?])
-
-Performs a dynamic load of the binary file {{LIBRARYFILE}}.
-
-WIll raise an error upon failure to find the symbol. Unless {{ERROR?}} is
-{{#f}}, in which case {{#f}} is returned.
-
-==== dynamic-library-procedure
-
- [procedure] (dynamic-library-procedure LIBRARYFILE SYMBOLNAME HANDLER [ERROR?])
-
-Performs a symbol to address lookup in the dynamic load library
-{{LIBRARYFILE}}. Attempts to load the library if not already loaded.
-
-A {{symbol}} {{SYMBOLNAME}} will be converted to a {{string}}.
-
-{{HANDLER}} is a procedure of 4 arguments.
-
-Returns a {{procedure}} of N arguments, {{ARGS}}, with body
-{{(HANDLER LIBRARYFILE SYMBOLNAME POINTER ARGS)}}. {{PONTER}} is a {{pointer}}
-with an address value of the symbol in the library.
-
-WIll raise an error upon failure to find the symbol. Unless {{ERROR?}} is
-{{#f}}, in which case {{#f}} is returned.
-
-On platforms other than Windows the literal form of the symbol is attempted
-first, followed by a lookup with a leading underscore {{#\_}}.
-
-==== dynamic-library-variable
-
- [procedure] (dynamic-library-variable LIBRARYFILE SYMBOLNAME HANDLER [ERROR?])
-
-Performs a symbol to address lookup in the dynamic load library
-{{LIBRARYFILE}}. Attempts to load the library if not already loaded.
-
-A {{symbol}} {{SYMBOLNAME}} will be converted to a {{string}}.
-
-{{HANDLER}} is a procedure of 4 arguments.
-
-Returns a {{procedure}} of N arguments, {{ARGS}}, with body
-{{(HANDLER LIBRARYFILE SYMBOLNAME POINTER ARGS)}}. {{PONTER}} is a {{pointer}}
-with an address value of the symbol in the library.
-
-WIll raise an error upon failure to find the symbol. Unless {{ERROR?}} is
-{{#f}}, in which case {{#f}} is returned.
-
-On platforms other than Windows the literal form of the symbol is attempted
-first, followed by a lookup with a leading underscore {{#\_}}.
-
-The distinction between a procedure and variable symbol lookup is platform
-dependent, if even possible. On Windows {{dynamic-library-variable}} will
-always fail. On all other supported platforms {{dynamic-library-variable}} will
-do the right thing.
-
==== set-dynamic-load-mode!
[procedure] (set-dynamic-load-mode! MODELIST)
@@ -160,8 +97,6 @@ symbols (or a single symbol) taken from the following set:
Note that this procedure does not control the way Scheme variables are handled -
this facility is mainly of interest when accessing foreign code.
-DEPRECATED - See the [[http://chicken.wiki.br/Parameters#dynamic-load-mode|dynamic-load-mode]] parameter
-
=== Read-eval-print loop
diff --git a/runtime.c b/runtime.c
index 9a10ba07..3e8d5a43 100644
--- a/runtime.c
+++ b/runtime.c
@@ -497,17 +497,7 @@ static void C_fcall remark(C_word *x) C_regparm;
static C_word C_fcall intern0(C_char *name) C_regparm;
static void C_fcall update_locative_table(int mode) C_regparm;
static C_word get_unbound_variable_value(C_word sym);
-static LF_LIST *find_lf_list_node(C_char *name);
-static C_char *checked_string_argument(char *loc, C_word hstr);
-static C_char *checked_string_or_null_argument(char *loc, C_word hstr);
-static void checked_library_query_arguments(char *loc,
- C_word libnam, C_word libhdl, C_word lfcnt,
- char **name, void **handle, int *count);
-static LF_LIST *make_lf_list_node(C_word *lf, int count, C_PTABLE_ENTRY *ptable, C_char *name, void *handle);
-static void link_lf_list_node(LF_LIST *node);
-static void unlink_lf_list_node(LF_LIST *node);
-static void destroy_lf_list_node(LF_LIST *node);
-static C_char *make_underscore_symstr(C_char *sym);
+static LF_LIST *find_module_handle(C_char *name);
static C_ccall void call_cc_wrapper(C_word c, C_word closure, C_word k, C_word result) C_noret;
static C_ccall void call_cc_values_wrapper(C_word c, C_word closure, C_word k, ...) C_noret;
@@ -732,7 +722,7 @@ int CHICKEN_initialize(int heap, int stack, int symbols, void *toplevel)
static C_PTABLE_ENTRY *create_initial_ptable()
{
- C_PTABLE_ENTRY *pt = (C_PTABLE_ENTRY *)C_malloc(sizeof(C_PTABLE_ENTRY) * 74);
+ C_PTABLE_ENTRY *pt = (C_PTABLE_ENTRY *)C_malloc(sizeof(C_PTABLE_ENTRY) * 66);
int i = 0;
if(pt == NULL)
@@ -756,17 +746,8 @@ static C_PTABLE_ENTRY *create_initial_ptable()
C_pte(C_decode_seconds);
C_pte(C_get_environment_variable);
C_pte(C_stop_timer);
- C_pte(C_dlopen_flags);
- C_pte(C_set_dlopen_flags);
C_pte(C_dload);
- C_pte(C_dunload);
- C_pte(C_dynamic_library_names);
- C_pte(C_dynamic_library_data);
- C_pte(C_chicken_library_literal_frame);
- C_pte(C_chicken_library_ptable);
- C_pte(C_dynamic_library_load);
- C_pte(C_dynamic_library_symbol);
- C_pte(C_dynamic_library_unload);
+ C_pte(C_set_dlopen_flags);
C_pte(C_become);
C_pte(C_apply_values);
C_pte(C_times);
@@ -811,6 +792,7 @@ static C_PTABLE_ENTRY *create_initial_ptable()
C_pte(C_register_finalizer);
C_pte(C_locative_ref);
C_pte(C_call_with_cthulhu);
+ C_pte(C_dunload);
pt[ i ].id = NULL;
return pt;
}
@@ -1863,66 +1845,6 @@ void C_zap_strings(C_word str)
/* Register/unregister literal frame: */
-static LF_LIST *
-make_lf_list_node(C_word *lf, int count, C_PTABLE_ENTRY *ptable, C_char *name, void *handle)
-{
- LF_LIST *node = (LF_LIST *)C_malloc(sizeof(LF_LIST));
-
- if(NULL == node)
- barf(C_OUT_OF_MEMORY_ERROR, "make_lf_list_node");
-
- node->lf = lf;
- node->count = count;
- node->ptable = ptable;
- node->module_name = name;
- node->module_handle = handle;
-
- return node;
-}
-
-
-static void
-link_lf_list_node(LF_LIST *node)
-{
- if(lf_list) lf_list->prev = node;
- node->next = lf_list;
- node->prev = NULL;
- lf_list = node;
-}
-
-
-static void
-unlink_lf_list_node(LF_LIST *node)
-{
- if (node->next) node->next->prev = node->prev;
- if (node->prev) node->prev->next = node->next;
- if (lf_list == node) lf_list = node->next;
-}
-
-
-static void
-destroy_lf_list_node(LF_LIST *node)
-{
- unlink_lf_list_node(node);
- C_free(node->module_name);
- C_free(node);
-}
-
-
-static LF_LIST *
-find_lf_list_node(C_char *name)
-{
- LF_LIST *np;
-
- for(np = lf_list; np != NULL; np = np->next) {
- if(np->module_name != NULL && !C_strcmp(np->module_name, name))
- return np;
- }
-
- return NULL;
-}
-
-
void C_initialize_lf(C_word *lf, int count)
{
while(count-- > 0)
@@ -1938,9 +1860,15 @@ void *C_register_lf(C_word *lf, int count)
void *C_register_lf2(C_word *lf, int count, C_PTABLE_ENTRY *ptable)
{
+ LF_LIST *node = (LF_LIST *)C_malloc(sizeof(LF_LIST));
LF_LIST *np;
- LF_LIST *node = make_lf_list_node(lf, count, ptable, NULL, NULL);
int status = 0;
+
+ node->lf = lf;
+ node->count = count;
+ node->ptable = ptable;
+ node->module_name = NULL;
+ node->module_handle = NULL;
if(reload_lf != NULL) {
if(debug_mode)
@@ -1958,191 +1886,44 @@ void *C_register_lf2(C_word *lf, int count, C_PTABLE_ENTRY *ptable)
node->module_handle = current_module_handle;
current_module_handle = NULL;
- if(reload_lf != node) link_lf_list_node(node);
- else reload_lf = NULL;
-
- return (void *)node;
-}
-
-
-void C_unregister_lf(void *handle)
-{
- destroy_lf_list_node((LF_LIST *)handle);
-}
-
-
-void C_ccall
-C_dynamic_library_names(C_word c, C_word closure, C_word k)
-{
- LF_LIST *np;
- C_word olst = C_SCHEME_END_OF_LIST;
-
- if(c != 2) C_bad_argc(c, 2);
+ if(reload_lf != node) {
+ if(lf_list) lf_list->prev = node;
- for(np = lf_list; np; np = np->next) {
- if(NULL != np->module_name && NULL != np->module_handle) {
- C_word str = C_string2(C_heaptop, np->module_name);
- olst = C_h_pair(str, olst);
- }
+ node->next = lf_list;
+ node->prev = NULL;
+ lf_list = node;
}
+ else reload_lf = NULL;
- C_kontinue(k, olst);
-}
-
-
-static C_char *
-checked_string_argument(char *loc, C_word hstr)
-{
- int len;
- C_char *cstr;
-
- if (!C_immediatep(hstr) && C_STRING_TYPE == C_header_bits(hstr)) {
- /* make copy of heap string so movement unnoticeable */
- len = C_header_size(hstr);
- if(NULL == (cstr = (char *)C_malloc(len + 1)))
- barf(C_OUT_OF_MEMORY_ERROR, loc);
- C_memcpy(cstr, C_c_string(hstr), len); (cstr)[ len ] = '\0';
- } else
- barf(C_BAD_ARGUMENT_TYPE_ERROR, loc, hstr);
-
- return cstr;
-}
-
-
-static C_char *
-checked_string_or_null_argument(char *loc, C_word hstr)
-{
- C_char *cstr = NULL;
-
- if(!C_immediatep(hstr) || C_SCHEME_FALSE != hstr)
- cstr = checked_string_argument(loc, hstr);
-
- return cstr;
+ return (void *)node;
}
-void C_ccall
-C_dynamic_library_data(C_word c, C_word closure, C_word k, C_word libnam)
+LF_LIST *find_module_handle(char *name)
{
LF_LIST *np;
- char *name;
- C_word olst = C_SCHEME_END_OF_LIST;
- if(c != 3) C_bad_argc(c, 3);
-
- name = checked_string_or_null_argument("##sys#dynamic-library-data", libnam);
-
- for(np = lf_list; np; np = np->next) {
- if( (!name && !np->module_name)
- || (name && np->module_name && !strcmp(name, np->module_name))) {
- C_word ptr = C_mpointer_or_false(C_heaptop, np->module_handle);
- C_word ent = C_h_list(3, ptr, C_fix(np->count), C_mk_bool(np->ptable));
- olst = C_h_pair(ent, olst);
- }
+ for(np = lf_list; np != NULL; np = np->next) {
+ if(np->module_name != NULL && !C_strcmp(np->module_name, name))
+ return np;
}
- if(name) C_free(name);
-
- C_kontinue(k, olst);
-}
-
-
-static void
-checked_library_query_arguments(char *loc,
- C_word libnam, C_word libhdl, C_word lfcnt,
- char **name, void **handle, int *count)
-{
- if(C_immediatep(libhdl) && C_SCHEME_FALSE == libhdl)
- *handle = NULL;
- else if (!C_immediatep(libhdl) && C_POINTER_TAG == C_block_header(libhdl))
- *handle = C_c_pointer_nn(libhdl);
- else
- barf(C_BAD_ARGUMENT_TYPE_ERROR, loc, libhdl);
-
- if(C_immediatep(lfcnt) && (C_FIXNUM_BIT & lfcnt))
- *count = C_unfix(lfcnt);
- else
- barf(C_BAD_ARGUMENT_TYPE_ERROR, loc, lfcnt);
-
- if(*count < 0)
- barf(C_BAD_ARGUMENT_TYPE_ERROR, loc, lfcnt);
-
- *name = checked_string_or_null_argument(loc, libnam);
+ return NULL;
}
-void C_ccall
-C_chicken_library_literal_frame(C_word c, C_word closure, C_word k,
- C_word libnam, C_word libhdl, C_word lfcnt)
+void C_unregister_lf(void *handle)
{
- int count;
- void *handle;
- char *name;
- LF_LIST *np;
- C_word olst = C_SCHEME_END_OF_LIST;
-
- if(c != 5) C_bad_argc(c, 5);
-
- checked_library_query_arguments(C_text("##sys#chicken-library-literal-frame"),
- libnam, libhdl, lfcnt,
- &name, &handle, &count);
-
- for(np = lf_list; np; np = np->next) {
- if( (!name && !np->module_name)
- || (name && np->module_name && !strcmp(name, np->module_name))) {
- C_word *lf = np->lf;
- if(lf && handle == np->module_handle && count == np->count) {
- int cnt;
- for(cnt = np->count; cnt--; ++lf) {
- olst = C_h_pair(*lf, olst);
- }
- }
- }
- }
-
- if(name) C_free(name);
-
- C_kontinue(k, olst);
-}
+ LF_LIST *node = (LF_LIST *) handle;
+ if (node->next) node->next->prev = node->prev;
-void C_ccall
-C_chicken_library_ptable(C_word c, C_word closure, C_word k,
- C_word libnam, C_word libhdl, C_word lfcnt, C_word inclptrs)
-{
- int count;
- void *handle;
- char *name;
- LF_LIST *np;
- C_word olst = C_SCHEME_END_OF_LIST;
-
- if(c != 6) C_bad_argc(c, 6);
+ if (node->prev) node->prev->next = node->next;
- checked_library_query_arguments(C_text("##sys#chicken-library-ptable"),
- libnam, libhdl, lfcnt,
- &name, &handle, &count);
-
- for(np = lf_list; np; np = np->next) {
- if( (!name && !np->module_name)
- || (name && np->module_name && !strcmp(name, np->module_name))) {
- C_PTABLE_ENTRY *pt = np->ptable;
- if(pt && handle == np->module_handle && count == np->count) {
- for(; pt->id; ++pt) {
- C_word str = C_string2(C_heaptop, pt->id);
- C_word ent = str;
- if(C_truep(inclptrs)) {
- C_word ptr = C_mpointer_or_false(C_heaptop, pt->ptr);
- ent = C_h_pair(str, ptr);
- }
- olst = C_h_pair(ent, olst);
- }
- }
- }
- }
-
- if(name) C_free(name);
+ if (lf_list == node) lf_list = node->next;
- C_kontinue(k, olst);
+ C_free(node->module_name);
+ C_free(node);
}
@@ -8605,17 +8386,6 @@ int C_do_unregister_finalizer(C_word x)
/* Dynamic loading of shared objects: */
-void C_ccall C_dlopen_flags(C_word c, C_word closure, C_word k)
-{
-#if !defined(NO_DLOAD2) && defined(HAVE_DLFCN_H)
- C_word flgs = C_h_list(2, (dlopen_flags & RTLD_NOW) ? C_SCHEME_TRUE : C_SCHEME_FALSE,
- (dlopen_flags & RTLD_GLOBAL) ? C_SCHEME_TRUE : C_SCHEME_FALSE);
- C_kontinue(k, flgs);
-#else
- C_kontinue(k, C_SCHEME_FALSE);
-#endif
-}
-
void C_ccall C_set_dlopen_flags(C_word c, C_word closure, C_word k, C_word now, C_word global)
{
#if !defined(NO_DLOAD2) && defined(HAVE_DLFCN_H)
@@ -8627,7 +8397,7 @@ void C_ccall C_set_dlopen_flags(C_word c, C_word closure, C_word k, C_word now,
void C_ccall C_dload(C_word c, C_word closure, C_word k, C_word name, C_word entry, C_word reloadable)
{
-#if !defined(NO_DLOAD2)
+#if !defined(NO_DLOAD2) && (defined(HAVE_DLFCN_H) || defined(HAVE_DL_H) || (defined(HAVE_LOADLIBRARY) && defined(HAVE_GETPROCADDRESS)))
/* Force minor GC: otherwise the lf may contain pointers to stack-data
(stack allocated interned symbols, for example) */
C_save_and_reclaim(dload_2, NULL, 4, k, name, entry, reloadable);
@@ -8641,33 +8411,106 @@ void C_ccall C_dload(C_word c, C_word closure, C_word k, C_word name, C_word ent
# undef DLOAD_2_DEFINED
#endif
-#if !defined(NO_DLOAD2) && !defined(DLOAD_2_DEFINED)
-# define DLOAD_2_DEFINED
+#if !defined(NO_DLOAD2) && defined(HAVE_DL_H) && !defined(DLOAD_2_DEFINED)
+# ifdef __hpux__
+# define DLOAD_2_DEFINED
void dload_2(void *dummy)
{
- void *handle;
- int ok;
- void *p = NULL;
- void *p2;
- C_word
+ void *handle, *p;
+ C_word reloadable = C_restore,
+ entry = C_restore,
+ name = C_restore,
+ k = C_restore;
+ C_char *mname = (C_char *)C_data_pointer(name);
+
+ /*
+ * C_fprintf(C_stderr,
+ * "shl_loading %s : %s\n",
+ * (char *) C_data_pointer(name),
+ * (char *) C_data_pointer(entry));
+ */
+
+ if(C_truep(reloadable) && (reload_lf = find_module_handle(mname)) != NULL) {
+ if(shl_unload((shl_t)reload_lf->module_handle) != 0)
+ panic(C_text("Unable to unload previously loaded compiled code"));
+ }
+ else reload_lf = NULL;
+
+ if ((handle = (void *) shl_load(mname,
+ BIND_IMMEDIATE | DYNAMIC_PATH,
+ 0L)) != NULL) {
+ shl_t shl_handle = (shl_t) handle;
+
+ /*** This version does not check for C_dynamic_and_unsafe. Fix it. */
+ if (shl_findsym(&shl_handle, (char *) C_data_pointer(entry), TYPE_PROCEDURE, &p) == 0) {
+ current_module_name = C_strdup(mname);
+ current_module_handle = handle;
+
+ if(debug_mode) {
+ if(reload_lf != NULL)
+ C_printf(C_text("[debug] reloading compiled module `%s' (previous handle was " UWORD_FORMAT_STRING ", new is "
+ UWORD_FORMAT_STRING ")\n"), current_module_name, (C_uword)reload_lf->module_handle,
+ (C_uword)current_module_handle);
+ else
+ C_printf(C_text("[debug] loading compiled module `%s' (handle is " UWORD_FORMAT_STRING ")\n"),
+ current_module_name, (C_uword)current_module_handle);
+ }
+
+ ((C_proc2)p)(2, C_SCHEME_UNDEFINED, k);
+ } else {
+ C_dlerror = (char *) C_strerror(errno);
+ shl_unload(shl_handle);
+ }
+ } else {
+ C_dlerror = (char *) C_strerror(errno);
+ }
+
+ C_kontinue(k, C_SCHEME_FALSE);
+}
+# endif
+#endif
+
+
+#if !defined(NO_DLOAD2) && defined(HAVE_DLFCN_H) && !defined(DLOAD_2_DEFINED)
+# ifndef __hpux__
+# define DLOAD_2_DEFINED
+void dload_2(void *dummy)
+{
+ void *handle, *p, *p2;
+ C_word
reloadable = C_restore,
entry = C_restore,
name = C_restore,
k = C_restore;
C_char *topname = (C_char *)C_data_pointer(entry);
C_char *mname = (C_char *)C_data_pointer(name);
+ C_char *tmp;
+ int ok;
- if(C_truep(reloadable) && (reload_lf = find_lf_list_node(mname)) != NULL) {
- if(0 != C_dynamic_library_close(reload_lf->module_handle))
+ if(C_truep(reloadable) && (reload_lf = find_module_handle(mname)) != NULL) {
+ if(C_dlclose(reload_lf->module_handle) != 0)
panic(C_text("Unable to unload previously loaded compiled code"));
}
else reload_lf = NULL;
- if((handle = C_dynamic_library_open(mname)) != NULL) {
- if ((p = C_dynamic_library_procedure(handle, topname)) != NULL) {
+ if((handle = C_dlopen(mname, dlopen_flags)) != NULL) {
+ if((p = C_dlsym(handle, topname)) == NULL) {
+ tmp = (C_char *)C_malloc(C_strlen(topname) + 2);
+
+ if(tmp == NULL)
+ panic(C_text("out of memory - cannot allocate toplevel name string"));
+
+ C_strcpy(tmp, C_text("_"));
+ C_strcat(tmp, topname);
+ p = C_dlsym(handle, tmp);
+ C_free(tmp);
+ }
+
+ if(p != NULL) {
/* check whether dloaded code is not a library unit
* and matches current safety setting: */
- p2 = C_dynamic_library_procedure(handle, C_text("C_dynamic_and_unsafe"));
+ if((p2 = C_dlsym(handle, C_text("C_dynamic_and_unsafe"))) == NULL)
+ p2 = C_dlsym(handle, C_text("_C_dynamic_and_unsafe"));
#ifdef C_UNSAFE_RUNTIME
ok = p2 != NULL; /* unsafe runtime, unsafe code */
@@ -8680,7 +8523,7 @@ void dload_2(void *dummy)
#ifdef C_UNSAFE_RUNTIME
barf(C_RUNTIME_UNSAFE_DLOAD_SAFE_ERROR, NULL);
#else
- barf(C_RUNTIME_SAFE_DLOAD_UNSAFE_ERROR, NULL);
+ barf(C_RUNTIME_SAFE_DLOAD_UNSAFE_ERROR, NULL);
#endif
current_module_name = C_strdup(mname);
@@ -8698,301 +8541,116 @@ void dload_2(void *dummy)
((C_proc2)p)(2, C_SCHEME_UNDEFINED, k); /* doesn't return */
}
- else
- C_dynamic_library_close(handle);
- }
+ C_dlclose(handle);
+ }
+
+ C_dlerror = (char *)dlerror();
C_kontinue(k, C_SCHEME_FALSE);
}
+# endif
#endif
-C_word C_ccall C_dunload(C_word name)
-{
- LF_LIST *np = find_lf_list_node(C_c_string(name));
- if(NULL != np && 0 == C_dynamic_library_close(np->module_handle)) {
- C_unregister_lf(np);
- return C_SCHEME_TRUE;
- }
- return C_SCHEME_FALSE;
-}
-
-
-/* Dynamic Library Access from C */
-
-C_regparm void * C_fcall
-C_dynamic_library_open(C_char *name)
+#if !defined(NO_DLOAD2) && (defined(HAVE_LOADLIBRARY) && defined(HAVE_GETPROCADDRESS)) && !defined(DLOAD_2_DEFINED)
+# define DLOAD_2_DEFINED
+void dload_2(void *dummy)
{
-#ifndef NO_DLOAD2
-
-# if defined(__hpux__) && defined(HAVE_DL_H)
-
- shl_t handle = shl_load(name, BIND_IMMEDIATE | DYNAMIC_PATH, 0L);
- if(NULL != handle) return (void *)handle;
- C_dlerror = (char *)C_strerror(errno);
-
-# elif defined(HAVE_DLFCN_H)
-
- void *handle = C_dlopen(name, dlopen_flags);
- if(NULL != handle) return handle;
- C_dlerror = (char *)dlerror();
-
-# elif defined(HAVE_LOADLIBRARY)
-
- HMODULE handle;
+ HINSTANCE handle;
+ int ok;
+ FARPROC p = NULL, p2;
+ C_word
+ reloadable = C_restore,
+ entry = C_restore,
+ name = C_restore,
+ k = C_restore;
+ C_char *topname = (C_char *)C_data_pointer(entry);
+ C_char *mname = (C_char *)C_data_pointer(name);
/* cannot use LoadLibrary on non-DLLs, so we use extension checking */
- int len = strlen(name);
- /* FIXME - probably should use _stricmp since Windows native */
- if( (len >= 5 && C_strncasecmp(".dll", name+len-4, 4))
- && (len >= 4 && C_strncasecmp(".so", name+len-3, 3))) {
- static char not_dll_msg[] = "unsuitable pathname extension - not a .DLL or .SO";
- C_dlerror = not_dll_msg;
- return NULL;
+ if (C_header_size(name) >= 5) {
+ char *n = (char*) C_data_pointer(name);
+ int l = C_header_size(name);
+ if (C_strncasecmp(".dll", n+l-5, 4) &&
+ C_strncasecmp(".so", n+l-4, 3))
+ C_kontinue(k, C_SCHEME_FALSE);
}
- handle = LoadLibrary(name);
- if(NULL != handle) return (void *)handle;
- C_dlerror = (char *)C_strerror(errno);
-
-# endif
-
-#endif
-
- return NULL;
-}
-
-
-static C_char *
-make_underscore_symstr(C_char *sym)
-{
- /* if we're out-of-memory don't report it here */
- char *usym = (C_char *)C_malloc(C_strlen(sym) + 2);
- if(NULL != usym) {
- C_strcpy(usym, C_text("_"));
- C_strcat(usym, sym);
+ if(C_truep(reloadable) && (reload_lf = find_module_handle((char *)C_data_pointer(name))) != NULL) {
+ if(FreeLibrary((HINSTANCE)reload_lf->module_handle) == 0)
+ panic(C_text("Unable to unload previously loaded compiled code"));
}
- return usym;
-}
-
+ else reload_lf = NULL;
-C_regparm void * C_fcall
-C_dynamic_library_procedure(void *handle, C_char *name)
-{
- void *ptr = C_dynamic_library_procedure_exact(handle, name);
+ if((handle = LoadLibrary(mname)) != NULL) {
+ if ((p = GetProcAddress(handle, topname)) != NULL) {
+ /* check whether dloaded code is not a library unit
+ * and matches current safety setting: */
+ p2 = GetProcAddress(handle, C_text("C_dynamic_and_unsafe"));
-#ifndef C_MICROSOFT_WINDOWS
- if(NULL == ptr) {
- char *tmp = make_underscore_symstr(name);
- if(NULL != tmp) {
- ptr = C_dynamic_library_procedure_exact(handle, tmp);
- C_free(tmp);
- }
- }
+#ifdef C_UNSAFE_RUNTIME
+ ok = p2 != NULL; /* unsafe runtime, unsafe code */
+#else
+ ok = p2 == NULL; /* safe runtime, safe code */
#endif
-
- return ptr;
-}
-
-
-C_regparm void * C_fcall
-C_dynamic_library_procedure_exact(void *handle, C_char *name)
-{
-#ifndef NO_DLOAD2
-
-# if defined(__hpux__) && defined(HAVE_DL_H)
-
- shl_t shl_handle = (shl_t)handle;
- void *ptr;
- if(0 == shl_findsym(&shl_handle, name, TYPE_PROCEDURE, &ptr)) return ptr;
- C_dlerror = (char *)C_strerror(errno);
-
-# elif defined(HAVE_DLFCN_H)
-
- void *ptr = C_dlsym(handle, name);
- if(NULL != ptr) return ptr;
- C_dlerror = (char *)dlerror();
-
-# elif defined(HAVE_GETPROCADDRESS)
-
- FARPROC ptr = GetProcAddress((HMODULE)handle, name);
- if(NULL != ptr) return (void *)ptr;
- C_dlerror = (char *)C_strerror(errno);
-
-# endif
-
+
+ /* unsafe marker not found and this is not a library unit? */
+ if(!ok && !C_strcmp(topname, "C_toplevel"))
+#ifdef C_UNSAFE_RUNTIME
+ barf(C_RUNTIME_UNSAFE_DLOAD_SAFE_ERROR, NULL);
+#else
+ barf(C_RUNTIME_SAFE_DLOAD_UNSAFE_ERROR, NULL);
#endif
- return NULL;
-}
-
+ current_module_name = C_strdup(mname);
+ current_module_handle = handle;
-C_regparm void * C_fcall
-C_dynamic_library_variable(void *handle, C_char *name)
-{
- void *ptr = C_dynamic_library_variable_exact(handle, name);
+ if(debug_mode) {
+ if(reload_lf != NULL)
+ C_printf(C_text("[debug] reloading compiled module `%s' (previous handle was " UWORD_FORMAT_STRING ", new is "
+ UWORD_FORMAT_STRING ")\n"), current_module_name, (C_uword)reload_lf->module_handle,
+ (C_uword)current_module_handle);
+ else
+ C_printf(C_text("[debug] loading compiled module `%s' (handle is " UWORD_FORMAT_STRING ")\n"),
+ current_module_name, (C_uword)current_module_handle);
+ }
-#ifndef C_MICROSOFT_WINDOWS
- if(NULL == ptr) {
- char *tmp = make_underscore_symstr(name);
- if(NULL != tmp) {
- ptr = C_dynamic_library_variable_exact(handle, tmp);
- C_free(tmp);
+ ((C_proc2)p)(2, C_SCHEME_UNDEFINED, k);
}
+ else FreeLibrary(handle);
}
-#endif
- return ptr;
+ C_dlerror = (char *) C_strerror(errno);
+ C_kontinue(k, C_SCHEME_FALSE);
}
+#endif
-C_regparm void * C_fcall
-C_dynamic_library_variable_exact(void *handle, C_char *name)
+C_word C_ccall C_dunload(C_word name)
{
-#ifndef NO_DLOAD2
-
-# if defined(__hpux__) && defined(HAVE_DL_H)
-
- shl_t shl_handle = (shl_t)handle;
- void *p;
- if(0 == shl_findsym(&shl_handle, name, TYPE_DATA, &p)) return p;
- C_dlerror = (char *)C_strerror(errno);
-
-# elif defined(HAVE_DLFCN_H)
-
- void *p = C_dlsym(handle, name);
- if(NULL != p) return p;
- C_dlerror = (char *)dlerror();
-
-# elif defined(HAVE_GETPROCADDRESS)
-
- /* Not Supported */
-
-# endif
-
-#endif
-
- return NULL;
-}
+ LF_LIST *m = find_module_handle(C_c_string(name));
+ if(m == NULL) return C_SCHEME_FALSE;
-C_regparm int C_fcall
-C_dynamic_library_close(void *handle)
-{
#ifndef NO_DLOAD2
-
# if defined(__hpux__) && defined(HAVE_DL_H)
-
- if(0 != shl_unload((shl_t)handle)) return -1;
- C_dlerror = (char *)C_strerror(errno);
-
+ if(shl_unload((shl_t)m->module_handle) != 0) return C_SCHEME_FALSE;
# elif defined(HAVE_DLFCN_H)
-
- if(0 != C_dlclose(handle)) return -1;
- C_dlerror = (char *)dlerror();
-
+ if(dlclose(m->module_handle) != 0) return C_SCHEME_FALSE;
# elif defined(HAVE_LOADLIBRARY)
-
- if(0 == FreeLibrary((HMODULE)handle)) return -1;
- C_dlerror = (char *)C_strerror(errno);
-
+ if(FreeLibrary(m->module_handle) == 0) return C_SCHEME_FALSE;
+# else
+ return C_SCHEME_FALSE;
# endif
-
+# else
+ return C_SCHEME_FALSE;
#endif
- return 0;
-}
-
-
-/* Dynamic Library Access from Scheme */
-
-void C_ccall
-C_dynamic_library_load(C_word c, C_word closure, C_word k, C_word name)
-{
- C_word succ = C_SCHEME_FALSE;
- C_char *pname;
-
- if(c != 3) C_bad_argc(c, 3);
-
- pname = checked_string_argument("##sys#dynamic-library-load", name); /* only free'ed on err */
-
- if(NULL == find_lf_list_node(pname)) {
- void *handle = C_dynamic_library_open(pname);
- if(NULL != handle) {
- LF_LIST *node = make_lf_list_node(NULL, 0, NULL, pname, handle);
- if(NULL != node) {
- link_lf_list_node(node);
- succ = C_SCHEME_TRUE;
- }
- else {
- C_free(pname);
- C_dynamic_library_close(handle);
- }
- }
- else
- C_free(pname);
- }
- /* loading a loaded library is not an error & we don't bump the dload refcnt */
- else succ = C_SCHEME_TRUE;
-
- C_kontinue(k, succ);
-}
-
-
-void C_ccall
-C_dynamic_library_symbol(C_word c, C_word closure, C_word k, C_word mname, C_word sname, C_word isprcsym)
-{
- C_word mptr = C_SCHEME_FALSE;
- C_char *pmname, *psname;
- LF_LIST *node;
-
- if(c != 5) C_bad_argc(c, 5);
-
- pmname = checked_string_argument("##sys#dynamic-library-symbol", mname);
- psname = checked_string_argument("##sys#dynamic-library-symbol", sname);
-
- node = find_lf_list_node(pmname);
- if(NULL != node) {
- /* note that this cannot fail out-of-line - so tmp strs will be free'ed */
- void *ptr = C_truep(isprcsym)
- ? C_dynamic_library_procedure(node->module_handle, psname)
- : C_dynamic_library_variable(node->module_handle, psname);
- mptr = C_mpointer_or_false(C_heaptop, ptr);
- }
-
- if(psname) C_free(psname);
- if(pmname) C_free(pmname);
-
- C_kontinue(k, mptr);
+ C_unregister_lf(m);
+ return C_SCHEME_TRUE;
}
-void C_ccall
-C_dynamic_library_unload(C_word c, C_word closure, C_word k, C_word name)
-{
- C_word succ = C_SCHEME_FALSE;
- C_char *pname;
- LF_LIST *node;
-
- if(c != 3) C_bad_argc(c, 3);
-
- pname = checked_string_argument("##sys#dynamic-library-unload", name);
-
- node = find_lf_list_node(pname);
- if(NULL != node) {
- /* note that this cannot fail out-of-line - so tmp str will be free'ed */
- int ret = C_dynamic_library_close(node->module_handle);
- destroy_lf_list_node(node);
- if(0 == ret) succ = C_SCHEME_TRUE;
- }
- /* unloading an non-loaded library is not an error */
- else succ = C_SCHEME_TRUE;
-
- if(pname) C_free(pname);
-
- C_kontinue(k, succ);
-}
-
void C_ccall C_become(C_word c, C_word closure, C_word k, C_word table)
{
C_word tp, x, old, new, i, *p;
Trap