Changeset 15869 in project


Ignore:
Timestamp:
09/15/09 01:07:21 (10 years ago)
Author:
kon
Message:

library Added new dynamic library sys namespace procedures
runtime Added support for non-chicken dynload, "folded" 'C_dload2' into platform indep routine
chicken Added new dynload procs
eval Made dynload flags a parameter, added new dynload routines (only a subset is "public", i.e. non-sys namespace)

Location:
chicken/trunk
Files:
5 edited

Legend:

Unmodified
Added
Removed
  • chicken/trunk/chicken.h

    r15823 r15869  
    15071507C_fctexport void C_ccall C_c_runtime(C_word c, C_word closure, C_word k) C_noret;
    15081508C_fctexport void C_ccall C_register_finalizer(C_word c, C_word closure, C_word k, C_word x, C_word proc) C_noret;
     1509C_fctexport void C_ccall C_dlopen_flags(C_word c, C_word closure, C_word k) C_noret;
    15091510C_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;
    15101511C_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;
     
    15141515C_fctexport void C_ccall C_call_with_cthulhu(C_word c, C_word self, C_word k, C_word proc) C_noret;
    15151516C_fctexport void C_ccall C_copy_closure(C_word c, C_word closure, C_word k, C_word proc) C_noret;
    1516 C_fctexport void C_literal_frame_info( C_word c, C_word closure, C_word k ) C_noret;
    1517 C_fctexport void C_literal_frame_toplevel( C_word c, C_word closure, C_word k, C_word modnam ) C_noret;
    1518 C_fctexport void C_literal_frame_ptable( C_word c, C_word closure, C_word k, C_word modnam, C_word inclptrs ) C_noret;
     1517
     1518C_fctexport void C_ccall C_dynamic_library_names(C_word c, C_word closure, C_word k) C_noret;
     1519C_fctexport void C_ccall C_dynamic_library_data(C_word c, C_word closure, C_word k, C_word libnam) C_noret;
     1520C_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;
     1521C_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;
     1522
     1523C_fctexport void C_ccall C_dynamic_library_load(C_word c, C_word closure, C_word k, C_word name) C_noret;
     1524C_fctexport void C_ccall C_dynamic_library_unload(C_word c, C_word closure, C_word k, C_word name) C_noret;
    15191525
    15201526#if !defined(__GNUC__) && !defined(__INTEL_COMPILER)
     
    16641670C_fctexport C_word C_fcall C_i_foreign_unsigned_integer_argumentp(C_word x) C_regparm;
    16651671
    1666 C_fctexport C_char *C_lookup_procedure_id(void *ptr);
    1667 C_fctexport void *C_lookup_procedure_ptr(C_char *id);
    1668 C_fctexport C_word C_dunload(C_word name);
     1672C_fctexport void * C_fcall C_dynamic_library_open(C_char *name) C_regparm;
     1673C_fctexport void * C_fcall C_dynamic_library_procedure(void *handle, C_char *name) C_regparm;
     1674C_fctexport void * C_fcall C_dynamic_library_procedure_exact(void *handle, C_char *name) C_regparm;
     1675C_fctexport void * C_fcall C_dynamic_library_variable(void *handle, C_char *name) C_regparm;
     1676C_fctexport void * C_fcall C_dynamic_library_variable_exact(void *handle, C_char *name) C_regparm;
     1677C_fctexport int C_fcall C_dynamic_library_close(void *handle) C_regparm;
     1678
     1679C_fctexport void * C_fcall C_dynamic_library_symbol(C_word mname, C_word sname, C_word isprcsym) C_regparm;
     1680
     1681C_fctexport C_char * C_lookup_procedure_id(void *ptr);
     1682C_fctexport void * C_lookup_procedure_ptr(C_char *id);
     1683C_fctexport C_word C_ccall C_dunload(C_word name);
    16691684
    16701685#ifdef C_SIXTY_FOUR
  • chicken/trunk/chicken.import.scm

    r15600 r15869  
    206206   eval-handler
    207207   er-macro-transformer
     208   set-dynamic-load-mode!                         ;DEPRECATED
     209   dynamic-load-mode
    208210   dynamic-load-libraries
     211   loaded-libraries
     212   dynamic-library-load
     213   dynamic-library-procedure
     214   dynamic-library-variable
    209215   with-exception-handler)
    210216 ##sys#chicken-macro-environment)       ;*** incorrect - won't work in compiled executable that does expansion
  • chicken/trunk/eval.scm

    r15830 r15869  
    874874(define-foreign-variable _dlerror c-string "C_dlerror")
    875875
    876 (define (set-dynamic-load-mode! mode)
    877   (let ([mode (if (pair? mode) mode (list mode))]
    878         [now #f]
    879         [global #t] )
    880     (let loop ([mode mode])
    881       (when (pair? mode)
    882         (case (##sys#slot mode 0)
    883           [(global) (set! global #t)]
    884           [(local) (set! global #f)]
    885           [(lazy) (set! now #f)]
    886           [(now) (set! now #t)]
    887           [else (##sys#signal-hook 'set-dynamic-load-mode! "invalid dynamic-load mode" (##sys#slot mode 0))] )
    888         (loop (##sys#slot mode 1)) ) )
    889     (##sys#set-dlopen-flags! now global) ) )
     876(define dynamic-load-mode)
     877(define set-dynamic-load-mode!)                         ;DEPRECATED
     878(let ()
     879
     880  (define (dynamic-load-flags->mode flags)
     881    (and flags
     882         (list (if (car flags) 'now 'lazy) (if (cadr flags) 'global 'local)) ) )
     883
     884  (define (dynamic-load-mode->flags mode)
     885    (let ((mode (if (pair? mode) mode (list mode)))
     886          (now #f)
     887          (global #t) )
     888      (let loop ((mode mode))
     889        (when (pair? mode)
     890          (case (car mode)
     891            ((global) (set! global #t))
     892            ((local)  (set! global #f))
     893            ((lazy)   (set! now #f))
     894            ((now)    (set! now #t))
     895            (else
     896             (##sys#signal-hook 'set-dynamic-load-mode! "invalid dynamic-load mode" (car mode)) ) )
     897          (loop (cdr mode)) ) )
     898      (list now global) ) )
     899
     900  (set! dynamic-load-mode
     901    (make-parameter (dynamic-load-flags->mode (##sys#dlopen-flags))
     902      (lambda (x)
     903        (cond ((or (pair? x) (symbol? x))
     904               (apply ##sys#set-dlopen-flags! (dynamic-load-mode->flags x))
     905               (dynamic-load-flags->mode (##sys#dlopen-flags)) )
     906              (else
     907                (dynamic-load-mode) ) ) ) ) )
     908             
     909  (set! set-dynamic-load-mode! (lambda (mode) (dynamic-load-mode mode) ) ) )
    890910
    891911(let ([read read]
     
    10331053                   (if lib
    10341054                       (##sys#list lib)
    1035                        (cons (##sys#string-append (##sys#slot uname 1) ##sys#load-library-extension)
     1055                       (cons (##sys#string-append (##sys#slot uname 1) ;symbol pname
     1056                                                  ##sys#load-library-extension)
    10361057                             (dynamic-load-libraries) ) ) ]
    10371058                  [top
     
    10481069                (cond [(null? libs) #f]
    10491070                      [(##sys#dload (##sys#make-c-string (##sys#slot libs 0)) top #f)
    1050                        (unless (memq id ##sys#features) (set! ##sys#features (cons id ##sys#features)))
     1071                       ; Cannot be in features yet but check anyway
     1072                       (unless (memq id ##sys#features)
     1073                         (set! ##sys#features (cons id ##sys#features)) )
    10511074                       #t]
    10521075                      [else (loop (##sys#slot libs 1))] ) ) ) ) ) ) ) )
     
    10601083(define load-library ##sys#load-library)
    10611084
    1062 ;; (loaded-libraries [COMBINE-ENTRIES?] [INCLUDE-SYSTEM-ENTRIES?])
    1063 ;; COMBINE-ENTRIES? : a boolean, collapse all literal-frame entries for the
    1064 ;; same library into a single entry, the default is #t.
    1065 ;; INCLUDE-SYSTEM-ENTRIES? : a boolean, include entries for system libraries, the
    1066 ;; default is #f.
    1067 ;; => ((<pathname> <literal-frame-count> <ptable?>)...)
    1068 ;; where <pathname> is #f (when runtime) or a string,
    1069 ;; <literal-frame-count> is the total of entrypoints (toplevel),
    1070 ;; and <ptable?> is a boolean indicating whether the lf has a ptable.
    1071 
    1072 (define (loaded-libraries #!optional (cmb? #t) (sys? #f))
    1073   (let ((ls (##sys#literal-frame-info)))
    1074     ; Everything wanted?
    1075     (if (and (not cmb?) sys?)
    1076         ; then everything it is
    1077         ls
    1078         ; else perform a "cull
    1079         (let loop ((ils ls) (ols '()))
    1080           (if (null? ils)
    1081               ols
    1082               (let* ((cur (car ils))
    1083                      (nxt (cdr ils))
    1084                      (nam (car cur))
    1085                      ; Is this a wanted system entry or not a system entry?
    1086                      (cur (and (or sys? (and nam (not (member nam (dynamic-load-libraries)))))
    1087                                cur)) )
    1088                 (cond ((not cur)
    1089                         (loop nxt ols) )
    1090                       ; Combining entries?
    1091                       (cmb?
    1092                         (let ((ext (alist-ref nam ols equal?)))
    1093                           (if ext
    1094                              (begin
    1095                                ; Accumulate frame count
    1096                                (set-car! ext (+ (car ext) (cadr cur)))
    1097                                ; Has any ptable then has a ptable
    1098                                (when (and (not (cadr ext)) (caddr cur))
    1099                                  (set-car! (cdr ext) #t) )
    1100                                (loop nxt ols) )
    1101                              (loop nxt (cons cur ols)) ) ) )
    1102                       (else
    1103                         (loop nxt (cons cur ols)) ) ) ) ) ) ) ) )
    1104 
    1105 (define (loaded-library-toplevel nam)
    1106  (when nam (##sys#check-string nam 'loaded-library-toplevel))
    1107  (##sys#literal-frame-toplevel (and nam (##sys#make-c-string nam))) )
    1108 
    1109 (define (loaded-library-ptable nam #!optional ptrs?)
    1110  (when nam (##sys#check-string nam 'loaded-library-ptable))
    1111  (##sys#literal-frame-ptable (and nam (##sys#make-c-string nam)) ptrs?) )
    1112 
     1085(define (dynamic-library-load name)
     1086  (##sys#check-string name 'dynamic-library-load)
     1087  (or (##sys#dynamic-library-load name)
     1088      (##sys#error 'dynamic-library-load "cannot load dynamic library" name _dlerror) ) )
     1089
     1090(define (loaded-libraries)
     1091  ; Ignore the names of explicitly loaded library units
     1092  (let loop ((ils (##sys#dynamic-library-names)) (ols '()))
     1093    (if (null? ils)
     1094        ols
     1095        (let ((nam (car ils)))
     1096          (loop (cdr ils) (if (member nam (dynamic-load-libraries)) ols (cons nam ols))) ) ) ) )
     1097
     1098;; (##sys#dynamic-library-procedure mname sname) => mname+sname-ptr
     1099;; (##sys#dynamic-library-variable mname sname) => mname+sname-ptr
     1100;;
     1101;; Will attempt to load (global lazy) the library should the attempt to
     1102;; resolve the symbol fail. Either this succeeds and the symbol is then
     1103;; resolved, or an error will be signaled.
     1104
     1105(define ##sys#dynamic-library-procedure)
     1106(define ##sys#dynamic-library-variable)
     1107(let ()
     1108
     1109  (define (checked-pointer loc ptrfnc mname sname)
     1110    (or (ptrfnc mname sname)
     1111        (and (parameterize ((dynamic-load-mode '(lazy global))) (dynamic-library-load mname))
     1112             (ptrfnc mname sname) )
     1113        (##sys#error loc "cannot resolve dynamic library symbol" mname sname _dlerror) ) )
     1114
     1115  (set! ##sys#dynamic-library-procedure
     1116    (lambda (mname sname)
     1117      (checked-pointer 'dynamic-library-procedure
     1118                       ##sys#dynamic-library-procedure-pointer mname sname) ) )
     1119
     1120  (set! ##sys#dynamic-library-variable
     1121    (lambda (mname sname)
     1122      (checked-pointer 'dynamic-library-variable
     1123                        ##sys#dynamic-library-variable-pointer mname sname) ) ) )
     1124
     1125;; (dynamic-library-procedure mname sname handler) => procedure/n
     1126;; (dynamic-library-variable mname sname handler) => procedure/n
     1127;;
     1128;; The 'procedure/n' invokes the handler on (mname sname mname+sname-ptr n-args).
     1129;;
     1130;; Will attempt to load (global lazy) the library should the attempt to
     1131;; resolve the symbol fail. Either this succeeds and the symbol is then
     1132;; resolved, or an error will be signaled.
     1133
     1134(define (dynamic-library-procedure mname sname handler)
     1135  (##sys#check-string mname 'dynamic-library-procedure)
     1136  (##sys#check-closure handler 'dynamic-library-procedure)
     1137  (let ((prcnam (if (symbol? sname) (symbol->string sname) sname)))
     1138    (##sys#check-string prcnam 'dynamic-library-procedure)
     1139    (let ((ptr (##sys#dynamic-library-procedure mname sname handler)))
     1140      (lambda args (handler mname sname ptr args)) ) ) )
     1141
     1142(define (dynamic-library-variable mname sname handler)
     1143  (##sys#check-string mname 'dynamic-library-variable)
     1144  (##sys#check-closure handler 'dynamic-library-variable)
     1145  (let ((varnam (if (symbol? sname) (symbol->string sname) sname)))
     1146    (##sys#check-string varnam 'dynamic-library-variable)
     1147    (let ((ptr (##sys#dynamic-library-variable mname sname handler)))
     1148      (lambda args (handler mname sname ptr args)) ) ) )
    11131149
    11141150;;; Extensions:
  • chicken/trunk/library.scm

    r15823 r15869  
    365365;;; Dynamic Load
    366366
    367 (define ##sys#literal-frame-info (##core#primitive "C_literal_frame_info"))
    368 (define ##sys#literal-frame-toplevel (##core#primitive "C_literal_frame_toplevel"))
    369 (define ##sys#literal-frame-ptable (##core#primitive "C_literal_frame_ptable"))
     367(define ##sys#dlopen-flags (##core#primitive "C_dlopen_flags"))
     368(define ##sys#set-dlopen-flags! (##core#primitive "C_set_dlopen_flags"))
     369
     370;; Arbitrary library load
     371
     372(define ##sys#dynamic-library-load (##core#primitive "C_dynamic_library_load"))
     373
     374; Dynamic Unload not available on all platforms and to be used with caution!
     375(define ##sys#dynamic-library-unload (##core#primitive "C_dynamic_library_unload"))
     376
     377;; Chicken library load
    370378
    371379(define ##sys#dload (##core#primitive "C_dload"))
    372 (define ##sys#set-dlopen-flags! (##core#primitive "C_set_dlopen_flags"))
    373 
    374 ;; Dynamic Unload not available on all platforms and to be used with caution!
     380
     381; Dynamic Unload not available on all platforms and to be used with caution!
    375382(define (##sys#dunload name)
    376   (and-let* ((r (##core#inline "C_dunload" (##sys#make-c-string name))))
     383  (and-let* (((##core#inline "C_dunload" (##sys#make-c-string name))))
    377384    (##sys#gc #t)
    378385    #t ) )
     386
     387;; Introspection of loaded libraries
     388
     389; (##sys#dynamic-library-procedure-pointer mname sname) => mname+sname-ptr or #f
     390; (##sys#dynamic-library-variable-pointer mname sname) => mname+sname-ptr or #f
     391
     392(define ##sys#dynamic-library-procedure-pointer)
     393(define ##sys#dynamic-library-variable-pointer)
     394(let ((dynlibsymptr (foreign-lambda c-pointer "C_dynamic_library_symbol"
     395                                              scheme-object scheme-object scheme-object)))
     396  (set! ##sys#dynamic-library-procedure-pointer
     397    (lambda (mname sname) (dynlibsymptr mname sname #t) ) )
     398  (set! ##sys#dynamic-library-variable-pointer
     399    (lambda (mname sname) (dynlibsymptr mname sname #f) ) ) )
     400
     401; (##sys#dynamic-library-names)
     402; => (<pathname>...)
     403; Does not return the "name" of the running program (i.e. #f)
     404
     405(define ##sys#dynamic-library-names (##core#primitive "C_dynamic_library_names"))
     406
     407; (##sys#dynamic-library-data name)
     408; => ((<dload-handle> <literal-frame-count> <ptable?>)...)
     409; <dload-handle> is a pointer to the actual dload handle or #f
     410; <literal-frame-count> is the total of entrypoints (toplevel)
     411; <ptable?> is a boolean indicating whether the lib has a ptable
     412
     413(define ##sys#dynamic-library-data (##core#primitive "C_dynamic_library_data"))
     414
     415; (##sys#chicken-library-literal-frame name handle count)
     416; => (<lf[0]>...)
     417
     418(define ##sys#chicken-library-literal-frame (##core#primitive "C_chicken_library_literal_frame"))
     419
     420; (##sys#chicken-library-ptable name handle count pointer?)
     421; => ((<ptable[0].id> . <ptable[0].ptr>)...) when pointer?
     422; => (<ptable[0].id>...) when (not pointer?)
     423
     424(define ##sys#chicken-library-ptable (##core#primitive "C_chicken_library_ptable"))
    379425
    380426
  • chicken/trunk/runtime.c

    r15823 r15869  
    498498static void C_fcall update_locative_table(int mode) C_regparm;
    499499static C_word get_unbound_variable_value(C_word sym);
    500 static LF_LIST *find_module_handle(C_char *name);
     500static LF_LIST *find_lf_list_node(C_char *name);
     501static void checked_library_name_argument(char *loc, C_word libnam, char **name);
     502static void checked_library_query_arguments(char *loc,
     503                                            C_word libnam, C_word libhdl, C_word lfcnt,
     504                                            char **name, void **handle, int *count);
     505static LF_LIST *make_lf_list_node(C_word *lf, int count, C_PTABLE_ENTRY *ptable, C_char *name, void *handle);
     506static void link_lf_list_node(LF_LIST *node);
     507static void unlink_lf_list_node(LF_LIST *node);
     508static void unmake_lf_list_node(LF_LIST *node);
    501509
    502510static C_ccall void call_cc_wrapper(C_word c, C_word closure, C_word k, C_word result) C_noret;
     
    747755  C_pte(C_get_environment_variable);
    748756  C_pte(C_stop_timer);
     757  C_pte(C_dlopen_flags);
     758  C_pte(C_set_dlopen_flags);
    749759  C_pte(C_dload);
    750   C_pte(C_set_dlopen_flags);
     760  C_pte(C_dunload);
     761  C_pte(C_dynamic_library_names);
     762  C_pte(C_dynamic_library_data);
     763  C_pte(C_chicken_library_literal_frame);
     764  C_pte(C_chicken_library_ptable);
     765  C_pte(C_dynamic_library_open);
     766  C_pte(C_dynamic_library_procedure);
     767  C_pte(C_dynamic_library_variable);
     768  C_pte(C_dynamic_library_procedure_exact);
     769  C_pte(C_dynamic_library_variable_exact);
     770  C_pte(C_dynamic_library_close);
     771  C_pte(C_dynamic_library_load);
     772  C_pte(C_dynamic_library_symbol);
     773  C_pte(C_dynamic_library_unload);
    751774  C_pte(C_become);
    752775  C_pte(C_apply_values);
     
    793816  C_pte(C_locative_ref);
    794817  C_pte(C_call_with_cthulhu);
    795   C_pte(C_dunload);
    796818  pt[ i ].id = NULL;
    797819  return pt;
     
    18461868/* Register/unregister literal frame: */
    18471869
    1848 void C_initialize_lf(C_word *lf, int count)
    1849 {
    1850   while(count-- > 0)
    1851     *(lf++) = C_SCHEME_UNBOUND;
    1852 }
    1853 
    1854 
    1855 void *C_register_lf(C_word *lf, int count)
    1856 {
    1857   return C_register_lf2(lf, count, NULL);
    1858 }
    1859 
    1860 
    1861 void *C_register_lf2(C_word *lf, int count, C_PTABLE_ENTRY *ptable)
     1870
     1871static LF_LIST *
     1872make_lf_list_node(C_word *lf, int count, C_PTABLE_ENTRY *ptable, C_char *name, void *handle)
    18621873{
    18631874  LF_LIST *node = (LF_LIST *)C_malloc(sizeof(LF_LIST));
    1864   LF_LIST *np;
    1865   int status = 0;
    18661875
    18671876  node->lf = lf;
    18681877  node->count = count;
    18691878  node->ptable = ptable;
    1870   node->module_name = NULL;
    1871   node->module_handle = NULL;
     1879  node->module_name = name;
     1880  node->module_handle = handle;
     1881
     1882  return node;
     1883}
     1884
     1885
     1886static void
     1887link_lf_list_node(LF_LIST *node)
     1888{
     1889  if(lf_list) lf_list->prev = node;
     1890  node->next = lf_list;
     1891  node->prev = NULL;
     1892  lf_list = node;
     1893}
     1894
     1895
     1896static void
     1897unlink_lf_list_node(LF_LIST *node)
     1898{
     1899  if (node->next) node->next->prev = node->prev;
     1900  if (node->prev) node->prev->next = node->next;
     1901  if (lf_list == node) lf_list = node->next;
     1902}
     1903
     1904
     1905static void
     1906unmake_lf_list_node(LF_LIST *node)
     1907{
     1908  unlink_lf_list_node(node);
     1909  C_free(node->module_name);
     1910  C_free(node);
     1911}
     1912
     1913
     1914static LF_LIST *
     1915find_lf_list_node(C_char *name)
     1916{
     1917  LF_LIST *np;
     1918
     1919  for(np = lf_list; np != NULL; np = np->next) {
     1920    if(np->module_name != NULL && !C_strcmp(np->module_name, name))
     1921      return np;
     1922  }
     1923
     1924  return NULL;
     1925}
     1926
     1927
     1928void C_initialize_lf(C_word *lf, int count)
     1929{
     1930  while(count-- > 0)
     1931    *(lf++) = C_SCHEME_UNBOUND;
     1932}
     1933
     1934
     1935void *C_register_lf(C_word *lf, int count)
     1936{
     1937  return C_register_lf2(lf, count, NULL);
     1938}
     1939
     1940
     1941void *C_register_lf2(C_word *lf, int count, C_PTABLE_ENTRY *ptable)
     1942{
     1943  LF_LIST *node = make_lf_list_node(lf, count, ptable, NULL, NULL);
     1944  LF_LIST *np;
     1945  int status = 0;
    18721946 
    18731947  if(reload_lf != NULL) {
     
    18871961  current_module_handle = NULL;
    18881962
    1889   if(reload_lf != node) {
    1890     if(lf_list) lf_list->prev = node;
    1891 
    1892     node->next = lf_list;
    1893     node->prev = NULL;
    1894     lf_list = node;
    1895   }
     1963  if(reload_lf != node) link_lf_list_node(node);
    18961964  else reload_lf = NULL;
    18971965
     
    19021970void C_unregister_lf(void *handle)
    19031971{
    1904   LF_LIST *node = (LF_LIST *) handle;
    1905 
    1906   if (node->next) node->next->prev = node->prev;
    1907 
    1908   if (node->prev) node->prev->next = node->next;
    1909 
    1910   if (lf_list == node) lf_list = node->next;
    1911 
    1912   C_free(node->module_name);
    1913   C_free(node);
    1914 }
    1915 
    1916 
    1917 LF_LIST *find_module_handle(char *name)
     1972  unmake_lf_list_node((LF_LIST *)handle);
     1973}
     1974
     1975
     1976void C_ccall
     1977C_dynamic_library_names(C_word c, C_word closure, C_word k)
    19181978{
    19191979  LF_LIST *np;
    1920 
    1921   for(np = lf_list; np != NULL; np = np->next) {
    1922     if(np->module_name != NULL && !C_strcmp(np->module_name, name))
    1923       return np;
    1924   }
    1925 
    1926   return NULL;
     1980  C_word olst = C_SCHEME_END_OF_LIST;
     1981
     1982  if(c != 2) C_bad_argc(c, 2);
     1983
     1984  for(np = lf_list; np; np = np->next) {
     1985    if(NULL != np->module_name && NULL != np->module_handle) {
     1986      C_word str = C_string2(C_heaptop, np->module_name);
     1987      olst = C_h_pair(str, olst);
     1988    }
     1989  }
     1990
     1991  C_kontinue(k, olst);
     1992}
     1993
     1994
     1995static void
     1996checked_library_name_argument(char *loc, C_word libnam, char **name)
     1997{
     1998  if(C_immediatep(libnam) && C_SCHEME_FALSE == libnam)
     1999    *name = NULL;
     2000  else if (!C_immediatep(libnam) && C_STRING_TYPE == C_header_bits(libnam)) {
     2001    /* Make copy of module name string so cannot be corrupted */
     2002    int len = C_header_size(libnam);
     2003    if(STRING_BUFFER_SIZE <= len) {
     2004      if(NULL == (*name = (char *)C_malloc(len + 1)))
     2005         barf(C_OUT_OF_MEMORY_ERROR, loc);
     2006    } else
     2007      *name = buffer;
     2008    C_memcpy(*name, C_c_string(libnam), len); (*name)[ len ] = '\0';
     2009  } else
     2010    barf(C_BAD_ARGUMENT_TYPE_ERROR, loc, libnam);
    19272011}
    19282012
    19292013
    19302014void C_ccall
    1931 C_literal_frame_info( C_word c, C_word closure, C_word k )
     2015C_dynamic_library_data(C_word c, C_word closure, C_word k, C_word libnam)
    19322016{
    19332017  LF_LIST *np;
    1934   C_word mods = C_SCHEME_END_OF_LIST;
    1935 
    1936   for( np = lf_list; np; np = np->next ) {
    1937     C_word str = C_string2( C_heaptop, np->module_name );
    1938     C_word ent = C_h_list( 3, str, C_fix( np->count ), C_mk_bool( np->ptable ) );
    1939     /*assert( np->lf ? np->count : 1 );*/
    1940     mods = C_h_pair( ent, mods );
    1941   }
    1942 
    1943   C_kontinue( k, mods );
     2018  char *name;
     2019  C_word olst = C_SCHEME_END_OF_LIST;
     2020
     2021  if(c != 3) C_bad_argc(c, 3);
     2022
     2023  checked_library_name_argument("##sys#dynamic-library-data", libnam, &name);
     2024
     2025  for(np = lf_list; np; np = np->next) {
     2026    if(   (!name && !np->module_name)
     2027       || (name && np->module_name && !strcmp(name, np->module_name))) {
     2028    C_word ptr = C_mpointer_or_false(C_heaptop, np->module_handle);
     2029    C_word ent = C_h_list(3, ptr, C_fix(np->count), C_mk_bool(np->ptable));
     2030    olst = C_h_pair(ent, olst);
     2031    }
     2032  }
     2033
     2034  if(name && name != buffer) C_free(name);
     2035
     2036  C_kontinue(k, olst);
     2037}
     2038
     2039
     2040static void
     2041checked_library_query_arguments(char *loc,
     2042                                C_word libnam, C_word libhdl, C_word lfcnt,
     2043                                char **name, void **handle, int *count)
     2044{
     2045  if(C_immediatep(libhdl) && C_SCHEME_FALSE == libhdl)
     2046    *handle = NULL;
     2047  else if (!C_immediatep(libhdl) && C_POINTER_TAG == C_block_header(libhdl))
     2048    *handle = C_c_pointer_nn(libhdl);
     2049  else
     2050    barf(C_BAD_ARGUMENT_TYPE_ERROR, loc, libhdl);
     2051
     2052  if(C_immediatep(lfcnt) && (C_FIXNUM_BIT & lfcnt))
     2053    *count = C_unfix(lfcnt);
     2054  else
     2055    barf(C_BAD_ARGUMENT_TYPE_ERROR, loc, lfcnt);
     2056
     2057  if(*count < 0)
     2058    barf(C_BAD_ARGUMENT_TYPE_ERROR, loc, lfcnt);
     2059
     2060  /*assert(*handle && *count);*/
     2061
     2062  checked_library_name_argument(loc, libnam, name);
    19442063}
    19452064
    19462065
    19472066void C_ccall
    1948 C_literal_frame_toplevel( C_word c, C_word closure, C_word k, C_word modnam )
    1949 {
     2067C_chicken_library_literal_frame(C_word c, C_word closure, C_word k,
     2068                                C_word libnam, C_word libhdl, C_word lfcnt)
     2069{
     2070  int count;
     2071  void *handle;
     2072  char *name;
    19502073  LF_LIST *np;
    1951   C_word prcs = C_SCHEME_END_OF_LIST;
    1952 
    1953   if( c != 3 ) C_bad_argc( c, 3 );
    1954 
    1955   if( (C_immediatep( modnam ) && C_SCHEME_FALSE != modnam)
    1956       || (!C_immediatep( modnam ) && C_STRING_TYPE != C_header_bits( modnam ))  )
    1957     barf( C_BAD_ARGUMENT_TYPE_ERROR, "##sys#literal-frame-toplevel", modnam );
    1958 
    1959   for( np = lf_list; np; np = np->next ) {
    1960     if( (C_SCHEME_FALSE == modnam && !np->module_name)
    1961         || (C_SCHEME_FALSE != modnam
    1962             && np->module_name && !strcmp( np->module_name, C_c_string( modnam ) )) ) {
     2074  C_word olst = C_SCHEME_END_OF_LIST;
     2075
     2076  if(c != 5) C_bad_argc(c, 5);
     2077
     2078  checked_library_query_arguments(C_text("##sys#chicken-library-literal-frame"),
     2079                                  libnam, libhdl, lfcnt,
     2080                                  &name, &handle, &count);
     2081
     2082  for(np = lf_list; np; np = np->next) {
     2083    if(   (!name && !np->module_name)
     2084       || (name && np->module_name && !strcmp(name, np->module_name))) {
    19632085      C_word *lf = np->lf;
    1964       if( lf ) {
    1965         int cnt = np->count;
    1966         /*assert( np->count );*/
    1967         for( ; cnt--; ++lf ) {
    1968           prcs = C_h_pair( *lf, prcs );
     2086      if(lf && handle == np->module_handle && count == np->count) {
     2087        int cnt;
     2088        for(cnt = np->count; cnt--; ++lf) {
     2089          olst = C_h_pair(*lf, olst);
    19692090        }
    19702091      }
    19712092    }
    19722093  }
    1973 printf( "\n" );
    1974 
    1975   C_kontinue( k, prcs );
     2094 
     2095  if(name && name != buffer) C_free(name);
     2096
     2097  C_kontinue(k, olst);
    19762098}
    19772099
    19782100
    19792101void C_ccall
    1980 C_literal_frame_ptable( C_word c, C_word closure, C_word k, C_word modnam, C_word inclptrs )
    1981 {
     2102C_chicken_library_ptable(C_word c, C_word closure, C_word k,
     2103                         C_word libnam, C_word libhdl, C_word lfcnt, C_word inclptrs)
     2104{
     2105  int count;
     2106  void *handle;
     2107  char *name;
    19822108  LF_LIST *np;
    1983   C_word prcs = C_SCHEME_END_OF_LIST;
    1984 
    1985   if( c != 4 ) C_bad_argc( c, 4 );
    1986 
    1987   if( (C_immediatep( modnam ) && C_SCHEME_FALSE != modnam)
    1988       || (!C_immediatep( modnam ) && C_STRING_TYPE != C_header_bits( modnam ))  )
    1989     barf( C_BAD_ARGUMENT_TYPE_ERROR, "##sys#literal-frame-ptable", modnam );
    1990 
    1991   for( np = lf_list; np; np = np->next ) {
    1992     if( (C_SCHEME_FALSE == modnam && !np->module_name)
    1993         || (C_SCHEME_FALSE != modnam
    1994             && np->module_name && !strcmp( np->module_name, C_c_string( modnam ) )) ) {
     2109  C_word olst = C_SCHEME_END_OF_LIST;
     2110
     2111  if(c != 6) C_bad_argc(c, 6);
     2112
     2113  checked_library_query_arguments(C_text("##sys#chicken-library-ptable"),
     2114                                  libnam, libhdl, lfcnt,
     2115                                  &name, &handle, &count);
     2116
     2117  for(np = lf_list; np; np = np->next) {
     2118    if(   (!name && !np->module_name)
     2119       || (name && np->module_name && !strcmp(name, np->module_name))) {
    19952120      C_PTABLE_ENTRY *pt = np->ptable;
    1996       if( pt ) {
    1997         for( ; pt->id; ++pt ) {
    1998           C_word str = C_string2( C_heaptop, pt->id );
     2121      if(pt && handle == np->module_handle && count == np->count) {
     2122        for(; pt->id; ++pt) {
     2123          C_word str = C_string2(C_heaptop, pt->id);
    19992124          C_word ent = str;
    2000           if( C_truep( inclptrs ) ) {
    2001             C_word ptr = C_mpointer( C_heaptop, pt->ptr );
    2002             ent = C_h_pair( str, ptr );
     2125          if(C_truep(inclptrs)) {
     2126            C_word ptr = C_mpointer_or_false(C_heaptop, pt->ptr);
     2127            ent = C_h_pair(str, ptr);
    20032128          }
    2004           prcs = C_h_pair( ent, prcs );
     2129          olst = C_h_pair(ent, olst);
    20052130        }
    20062131      }
    20072132    }
    20082133  }
    2009 
    2010   C_kontinue( k, prcs );
     2134 
     2135  if(name && name != buffer) C_free(name);
     2136
     2137  C_kontinue(k, olst);
    20112138}
    20122139
     
    84718598/* Dynamic loading of shared objects: */
    84728599
     8600void C_ccall C_dlopen_flags(C_word c, C_word closure, C_word k)
     8601{
     8602#if !defined(NO_DLOAD2) && defined(HAVE_DLFCN_H)
     8603  C_word flgs = C_h_list(2, (dlopen_flags & RTLD_NOW) ? C_SCHEME_TRUE : C_SCHEME_FALSE,
     8604                            (dlopen_flags & RTLD_GLOBAL) ? C_SCHEME_TRUE : C_SCHEME_FALSE);
     8605  C_kontinue(k, flgs);
     8606#else
     8607  C_kontinue(k, C_SCHEME_FALSE);
     8608#endif
     8609}
     8610
    84738611void C_ccall C_set_dlopen_flags(C_word c, C_word closure, C_word k, C_word now, C_word global)
    84748612{
     
    84828620void C_ccall C_dload(C_word c, C_word closure, C_word k, C_word name, C_word entry, C_word reloadable)
    84838621{
    8484 #if !defined(NO_DLOAD2) && (defined(HAVE_DLFCN_H) || defined(HAVE_DL_H) || (defined(HAVE_LOADLIBRARY) && defined(HAVE_GETPROCADDRESS)))
     8622#if !defined(NO_DLOAD2)
    84858623  /* Force minor GC: otherwise the lf may contain pointers to stack-data
    84868624     (stack allocated interned symbols, for example) */
     
    84968634#endif
    84978635
    8498 #if !defined(NO_DLOAD2) && defined(HAVE_DL_H) && !defined(DLOAD_2_DEFINED)
    8499 # ifdef __hpux__
    8500 #  define DLOAD_2_DEFINED
     8636#if !defined(NO_DLOAD2) && !defined(DLOAD_2_DEFINED)
     8637# define DLOAD_2_DEFINED
    85018638void dload_2(void *dummy)
    85028639{
    8503   void *handle, *p;
    8504   C_word reloadable = C_restore,
    8505          entry = C_restore,
    8506          name = C_restore,
    8507          k = C_restore;
     8640  void *handle;
     8641  int ok;
     8642  void *p = NULL;
     8643  void *p2;
     8644  C_word
     8645    reloadable = C_restore,
     8646    entry = C_restore,
     8647    name = C_restore,
     8648    k = C_restore;
     8649  C_char *topname = (C_char *)C_data_pointer(entry);
    85088650  C_char *mname = (C_char *)C_data_pointer(name);
    85098651
    8510   /*
    8511    * C_fprintf(C_stderr,
    8512    *   "shl_loading %s : %s\n",
    8513    *   (char *) C_data_pointer(name),
    8514    *   (char *) C_data_pointer(entry));
    8515    */
    8516 
    8517   if(C_truep(reloadable) && (reload_lf = find_module_handle(mname)) != NULL) {
    8518     if(shl_unload((shl_t)reload_lf->module_handle) != 0)
     8652  if(C_truep(reloadable) && (reload_lf = find_lf_list_node(C_c_string(name))) != NULL) {
     8653    if(0 != C_dynamic_library_close(reload_lf->module_handle))
    85198654      panic(C_text("Unable to unload previously loaded compiled code"));
    85208655  }
    85218656  else reload_lf = NULL;
    85228657
    8523   if ((handle = (void *) shl_load(mname,
    8524                                   BIND_IMMEDIATE | DYNAMIC_PATH,
    8525                                   0L)) != NULL) {
    8526     shl_t shl_handle = (shl_t) handle;
    8527 
    8528     /*** This version does not check for C_dynamic_and_unsafe. Fix it. */
    8529     if (shl_findsym(&shl_handle, (char *) C_data_pointer(entry), TYPE_PROCEDURE, &p) == 0) {
     8658  if((handle = C_dynamic_library_open(mname)) != NULL) {
     8659    if ((p = C_dynamic_library_procedure(handle, topname)) != NULL) {
     8660      /* check whether dloaded code is not a library unit
     8661       * and matches current safety setting: */
     8662      p2 = C_dynamic_library_procedure(handle, C_text("C_dynamic_and_unsafe"));
     8663
     8664#ifdef C_UNSAFE_RUNTIME
     8665      ok = p2 != NULL;          /* unsafe runtime, unsafe code */
     8666#else
     8667      ok = p2 == NULL;          /* safe runtime, safe code */
     8668#endif
     8669     
     8670      /* unsafe marker not found and this is not a library unit? */
     8671      if(!ok && !C_strcmp(topname, "C_toplevel"))
     8672#ifdef C_UNSAFE_RUNTIME
     8673        barf(C_RUNTIME_UNSAFE_DLOAD_SAFE_ERROR, NULL);
     8674#else
     8675        barf(C_RUNTIME_SAFE_DLOAD_UNSAFE_ERROR, NULL);
     8676#endif
     8677
    85308678      current_module_name = C_strdup(mname);
    85318679      current_module_handle = handle;
     
    85418689      }
    85428690
    8543       ((C_proc2)p)(2, C_SCHEME_UNDEFINED, k);
    8544     } else {
    8545       C_dlerror = (char *) C_strerror(errno);
    8546       shl_unload(shl_handle);
    8547     }
     8691      ((C_proc2)p)(2, C_SCHEME_UNDEFINED, k); /* doesn't return */
     8692    }
     8693    else
     8694      C_dynamic_library_close(handle);
     8695  }
     8696
     8697  C_kontinue(k, C_SCHEME_FALSE);
     8698}
     8699#endif
     8700
     8701
     8702C_word C_ccall C_dunload(C_word name)
     8703{
     8704  LF_LIST *np = find_lf_list_node(C_c_string(name));
     8705  if(NULL != np && 0 == C_dynamic_library_close(np->module_handle)) {
     8706    C_unregister_lf(np);
     8707    return C_SCHEME_TRUE;
     8708  }
     8709  return C_SCHEME_FALSE;
     8710}
     8711
     8712
     8713C_regparm void * C_fcall
     8714C_dynamic_library_open(C_char *name)
     8715{
     8716#ifndef NO_DLOAD2
     8717
     8718# if defined(__hpux__) && defined(HAVE_DL_H)
     8719
     8720  shl_t handle = shl_load(name, BIND_IMMEDIATE | DYNAMIC_PATH, 0L);
     8721  if(NULL != handle) return (void *)handle;
     8722  C_dlerror = (char *) C_strerror(errno);
     8723
     8724# elif defined(HAVE_DLFCN_H)
     8725
     8726  void *handle = C_dlopen(name, dlopen_flags);
     8727  if(NULL != handle) return handle;
     8728  C_dlerror = (char *)dlerror();
     8729
     8730# elif defined(HAVE_LOADLIBRARY)
     8731
     8732  /* cannot use LoadLibrary on non-DLLs, so we use extension checking */
     8733  int len = strlen(name);
     8734  if (len >= 5) {
     8735    if (C_strncasecmp(".dll", name+len-5, 4) &&
     8736        C_strncasecmp(".so", name+len-4, 3))
     8737      return NULL;
    85488738  } else {
     8739    HMODULE handle = LoadLibrary(name);
     8740    if(NULL != handle) return (void *)handle;
    85498741    C_dlerror = (char *) C_strerror(errno);
    85508742  }
    85518743
    8552   C_kontinue(k, C_SCHEME_FALSE);
    8553 }
    85548744# endif
    8555 #endif
    8556 
    8557 
    8558 #if !defined(NO_DLOAD2) && defined(HAVE_DLFCN_H) && !defined(DLOAD_2_DEFINED)
    8559 # ifndef __hpux__
    8560 #  define DLOAD_2_DEFINED
    8561 void dload_2(void *dummy)
    8562 {
    8563   void *handle, *p, *p2;
    8564   C_word
    8565     reloadable = C_restore,
    8566     entry = C_restore,
    8567     name = C_restore,
    8568     k = C_restore;
    8569   C_char *topname = (C_char *)C_data_pointer(entry);
    8570   C_char *mname = (C_char *)C_data_pointer(name);
    8571   C_char *tmp;
    8572   int ok;
    8573 
    8574   if(C_truep(reloadable) && (reload_lf = find_module_handle(mname)) != NULL) {
    8575     if(C_dlclose(reload_lf->module_handle) != 0)
    8576       panic(C_text("Unable to unload previously loaded compiled code"));
    8577   }
    8578   else reload_lf = NULL;
    8579 
    8580   if((handle = C_dlopen(mname, dlopen_flags)) != NULL) {
    8581     if((p = C_dlsym(handle, topname)) == NULL) {
    8582       tmp = (C_char *)C_malloc(C_strlen(topname) + 2);
    8583      
    8584       if(tmp == NULL)
    8585         panic(C_text("out of memory - cannot allocate toplevel name string"));
    8586      
    8587       C_strcpy(tmp, C_text("_"));
    8588       C_strcat(tmp, topname);
    8589       p = C_dlsym(handle, tmp);
    8590       C_free(tmp);
    8591     }
    8592 
    8593     if(p != NULL) {
    8594       /* check whether dloaded code is not a library unit
    8595        * and matches current safety setting: */
    8596       if((p2 = C_dlsym(handle, C_text("C_dynamic_and_unsafe"))) == NULL)
    8597         p2 = C_dlsym(handle, C_text("_C_dynamic_and_unsafe"));
    8598 
    8599 #ifdef C_UNSAFE_RUNTIME
    8600       ok = p2 != NULL;          /* unsafe runtime, unsafe code */
    8601 #else
    8602       ok = p2 == NULL;          /* safe runtime, safe code */
    8603 #endif
    8604      
    8605       /* unsafe marker not found and this is not a library unit? */
    8606       if(!ok && !C_strcmp(topname, "C_toplevel"))
    8607 #ifdef C_UNSAFE_RUNTIME
    8608         barf(C_RUNTIME_UNSAFE_DLOAD_SAFE_ERROR, NULL);
    8609 #else
    8610         barf(C_RUNTIME_SAFE_DLOAD_UNSAFE_ERROR, NULL);
    8611 #endif
    8612 
    8613       current_module_name = C_strdup(mname);
    8614       current_module_handle = handle;
    8615 
    8616       if(debug_mode) {
    8617         if(reload_lf != NULL)
    8618           C_printf(C_text("[debug] reloading compiled module `%s' (previous handle was " UWORD_FORMAT_STRING ", new is "
    8619                           UWORD_FORMAT_STRING ")\n"), current_module_name, (C_uword)reload_lf->module_handle,
    8620                    (C_uword)current_module_handle);
    8621         else
    8622           C_printf(C_text("[debug] loading compiled module `%s' (handle is " UWORD_FORMAT_STRING ")\n"),
    8623                    current_module_name, (C_uword)current_module_handle);
     8745
     8746#endif
     8747
     8748  return NULL;
     8749}
     8750
     8751
     8752C_regparm void * C_fcall
     8753C_dynamic_library_procedure(void *handle, C_char *name)
     8754{
     8755  void *p = C_dynamic_library_procedure_exact(handle, name);
     8756
     8757#ifndef C_MICROSOFT_WINDOWS
     8758  if(NULL == p) {
     8759    char *tmp = (C_char *)C_malloc(C_strlen(name) + 2);
     8760    if(NULL == tmp)
     8761      panic(C_text("out of memory - cannot allocate toplevel name string"));
     8762    C_strcpy(tmp, C_text("_"));
     8763    C_strcat(tmp, name);
     8764    p = C_dynamic_library_procedure_exact(handle, tmp);
     8765    C_free(tmp);
     8766  }
     8767#endif
     8768
     8769  return p;
     8770}
     8771
     8772
     8773/* Dynamic Library Access from C */
     8774
     8775C_regparm void * C_fcall
     8776C_dynamic_library_procedure_exact(void *handle, C_char *name)
     8777{
     8778#ifndef NO_DLOAD2
     8779
     8780# if defined(__hpux__) && defined(HAVE_DL_H)
     8781
     8782  shl_t shl_handle = (shl_t)handle;
     8783  void *p;
     8784  if(0 == shl_findsym(&shl_handle, name, TYPE_PROCEDURE, &p)) return p;
     8785  C_dlerror = (char *) C_strerror(errno);
     8786
     8787# elif defined(HAVE_DLFCN_H)
     8788
     8789  void *p = C_dlsym(handle, name);
     8790  if(NULL != p) return p;
     8791  C_dlerror = (char *)dlerror();
     8792
     8793# elif defined(HAVE_GETPROCADDRESS)
     8794
     8795  FARPROC p = GetProcAddress((HMODULE)handle, name);
     8796  if(NULL != p) return (void *)p;
     8797  C_dlerror = (char *) C_strerror(errno);
     8798
     8799# endif
     8800
     8801#endif
     8802
     8803  return NULL;
     8804}
     8805
     8806
     8807C_regparm void * C_fcall
     8808C_dynamic_library_variable(void *handle, C_char *name)
     8809{
     8810  void *p = C_dynamic_library_variable_exact(handle, name);
     8811
     8812#ifndef C_MICROSOFT_WINDOWS
     8813  if(NULL == p) {
     8814    char *tmp = (C_char *)C_malloc(C_strlen(name) + 2);
     8815    if(NULL == tmp)
     8816      panic(C_text("out of memory - cannot allocate toplevel name string"));
     8817    C_strcpy(tmp, C_text("_"));
     8818    C_strcat(tmp, name);
     8819    p = C_dynamic_library_variable_exact(handle, tmp);
     8820    C_free(tmp);
     8821  }
     8822#endif
     8823
     8824  return p;
     8825}
     8826
     8827
     8828C_regparm void * C_fcall
     8829C_dynamic_library_variable_exact(void *handle, C_char *name)
     8830{
     8831#ifndef NO_DLOAD2
     8832
     8833# if defined(__hpux__) && defined(HAVE_DL_H)
     8834
     8835  shl_t shl_handle = (shl_t)handle;
     8836  void *p;
     8837  if(0 == shl_findsym(&shl_handle, name, TYPE_DATA, &p)) return p;
     8838  C_dlerror = (char *) C_strerror(errno);
     8839
     8840# elif defined(HAVE_DLFCN_H)
     8841
     8842  void *p = C_dlsym(handle, name);
     8843  if(NULL != p) return p;
     8844  C_dlerror = (char *)dlerror();
     8845
     8846# elif defined(HAVE_GETPROCADDRESS)
     8847
     8848  /* Not Supported */
     8849
     8850# endif
     8851
     8852#endif
     8853
     8854  return NULL;
     8855}
     8856
     8857
     8858C_regparm int C_fcall
     8859C_dynamic_library_close(void *handle)
     8860{
     8861#ifndef NO_DLOAD2
     8862
     8863# if defined(__hpux__) && defined(HAVE_DL_H)
     8864
     8865  if(0 != shl_unload((shl_t)handle)) return -1;
     8866
     8867# elif defined(HAVE_DLFCN_H)
     8868
     8869  if(0 != C_dlclose(handle)) return -1;
     8870
     8871# elif defined(HAVE_LOADLIBRARY)
     8872
     8873  if(0 == FreeLibrary((HMODULE)handle)) return -1;
     8874
     8875# endif
     8876
     8877#endif
     8878
     8879  return 0;
     8880}
     8881
     8882
     8883/* Dynamic Library Access from Scheme */
     8884
     8885void C_ccall
     8886C_dynamic_library_load(C_word c, C_word closure, C_word k, C_word name)
     8887{
     8888  C_word done = C_SCHEME_FALSE;
     8889  C_char *mname;
     8890  void *handle;
     8891
     8892  if(c != 3) C_bad_argc(c, 3);
     8893
     8894  if (C_immediatep(name) || C_STRING_TYPE != C_header_bits(name))
     8895    barf(C_BAD_ARGUMENT_TYPE_ERROR, "##sys#dynamic-library-load", name);
     8896
     8897  mname = C_c_string(name);
     8898  handle = C_dynamic_library_open(mname);
     8899  if(NULL != handle) {
     8900    C_char *sname = C_strdup(mname);
     8901    if(NULL != sname) {
     8902      LF_LIST *node = make_lf_list_node(NULL, 0, NULL, sname, handle);
     8903      if(NULL != node) {
     8904        link_lf_list_node(node);
     8905        done = C_SCHEME_TRUE;
    86248906      }
    8625 
    8626       ((C_proc2)p)(2, C_SCHEME_UNDEFINED, k); /* doesn't return */
    8627     }
    8628 
    8629     C_dlclose(handle);
    8630   }
    8631  
    8632   C_dlerror = (char *)dlerror();
    8633   C_kontinue(k, C_SCHEME_FALSE);
    8634 }
    8635 # endif
    8636 #endif
    8637 
    8638 
    8639 #if !defined(NO_DLOAD2) && (defined(HAVE_LOADLIBRARY) && defined(HAVE_GETPROCADDRESS)) && !defined(DLOAD_2_DEFINED)
    8640 # define DLOAD_2_DEFINED
    8641 void dload_2(void *dummy)
    8642 {
    8643   HINSTANCE handle;
    8644   int ok;
    8645   FARPROC p = NULL, p2;
    8646   C_word
    8647     reloadable = C_restore,
    8648     entry = C_restore,
    8649     name = C_restore,
    8650     k = C_restore;
    8651   C_char *topname = (C_char *)C_data_pointer(entry);
    8652   C_char *mname = (C_char *)C_data_pointer(name);
    8653 
    8654   /* cannot use LoadLibrary on non-DLLs, so we use extension checking */
    8655   if (C_header_size(name) >= 5) {
    8656     char *n = (char*) C_data_pointer(name);
    8657     int l = C_header_size(name);
    8658     if (C_strncasecmp(".dll", n+l-5, 4) &&
    8659         C_strncasecmp(".so", n+l-4, 3))
    8660       C_kontinue(k, C_SCHEME_FALSE);
    8661   }
    8662 
    8663   if(C_truep(reloadable) && (reload_lf = find_module_handle((char *)C_data_pointer(name))) != NULL) {
    8664     if(FreeLibrary((HINSTANCE)reload_lf->module_handle) == 0)
    8665       panic(C_text("Unable to unload previously loaded compiled code"));
    8666   }
    8667   else reload_lf = NULL;
    8668 
    8669   if((handle = LoadLibrary(mname)) != NULL) {
    8670     if ((p = GetProcAddress(handle, topname)) != NULL) {
    8671       /* check whether dloaded code is not a library unit
    8672        * and matches current safety setting: */
    8673       p2 = GetProcAddress(handle, C_text("C_dynamic_and_unsafe"));
    8674 
    8675 #ifdef C_UNSAFE_RUNTIME
    8676       ok = p2 != NULL;          /* unsafe runtime, unsafe code */
    8677 #else
    8678       ok = p2 == NULL;          /* safe runtime, safe code */
    8679 #endif
    8680      
    8681       /* unsafe marker not found and this is not a library unit? */
    8682       if(!ok && !C_strcmp(topname, "C_toplevel"))
    8683 #ifdef C_UNSAFE_RUNTIME
    8684         barf(C_RUNTIME_UNSAFE_DLOAD_SAFE_ERROR, NULL);
    8685 #else
    8686         barf(C_RUNTIME_SAFE_DLOAD_UNSAFE_ERROR, NULL);
    8687 #endif
    8688 
    8689       current_module_name = C_strdup(mname);
    8690       current_module_handle = handle;
    8691 
    8692       if(debug_mode) {
    8693         if(reload_lf != NULL)
    8694           C_printf(C_text("[debug] reloading compiled module `%s' (previous handle was " UWORD_FORMAT_STRING ", new is "
    8695                           UWORD_FORMAT_STRING ")\n"), current_module_name, (C_uword)reload_lf->module_handle,
    8696                    (C_uword)current_module_handle);
    8697         else
    8698           C_printf(C_text("[debug] loading compiled module `%s' (handle is " UWORD_FORMAT_STRING ")\n"),
    8699                    current_module_name, (C_uword)current_module_handle);
     8907      else {
     8908        C_free(sname);
     8909        C_free(node);
    87008910      }
    8701 
    8702       ((C_proc2)p)(2, C_SCHEME_UNDEFINED, k);
    8703     }
    8704     else FreeLibrary(handle);
    8705   }
    8706 
    8707   C_dlerror = (char *) C_strerror(errno);
    8708   C_kontinue(k, C_SCHEME_FALSE);
    8709 }
    8710 #endif
    8711 
    8712 
    8713 C_word C_ccall C_dunload(C_word name)
    8714 {
    8715   LF_LIST *m = find_module_handle(C_c_string(name));
    8716 
    8717   if(m == NULL) return C_SCHEME_FALSE;
    8718 
    8719 #ifndef NO_DLOAD2
    8720 # if defined(__hpux__) && defined(HAVE_DL_H)
    8721   if(shl_unload((shl_t)m->module_handle) != 0) return C_SCHEME_FALSE;
    8722 # elif defined(HAVE_DLFCN_H)
    8723   if(dlclose(m->module_handle) != 0) return C_SCHEME_FALSE;
    8724 # elif defined(HAVE_LOADLIBRARY)
    8725   if(FreeLibrary(m->module_handle) == 0) return C_SCHEME_FALSE;
    8726 # else
    8727   return C_SCHEME_FALSE;
    8728 # endif
    8729 # else
    8730   return C_SCHEME_FALSE;
    8731 #endif
    8732 
    8733   C_unregister_lf(m);
    8734   return C_SCHEME_TRUE;
    8735 }
    8736 
     8911    }
     8912    else C_free(sname);
     8913  }
     8914
     8915  C_kontinue(k, done);
     8916}
     8917
     8918
     8919C_regparm void * C_fcall
     8920C_dynamic_library_symbol(C_word mname, C_word sname, C_word isprcsym)
     8921{
     8922  void *ptr = NULL;
     8923  LF_LIST *node;
     8924
     8925  if (C_immediatep(mname) || C_STRING_TYPE != C_header_bits(mname))
     8926    barf(C_BAD_ARGUMENT_TYPE_ERROR, "##sys#C_dynamic_library_symbol", mname);
     8927  if (C_immediatep(sname) || C_STRING_TYPE != C_header_bits(sname))
     8928    barf(C_BAD_ARGUMENT_TYPE_ERROR, "##sys#C_dynamic_library_symbol", sname);
     8929
     8930  node = find_lf_list_node(C_c_string(mname));
     8931  if(NULL != node) {
     8932    ptr = C_truep(isprcsym)
     8933            ? C_dynamic_library_procedure(node->module_handle, C_c_string(sname))
     8934            : C_dynamic_library_variable(node->module_handle, C_c_string(sname));
     8935  }   
     8936
     8937  return ptr;
     8938}
     8939
     8940
     8941void C_ccall
     8942C_dynamic_library_unload(C_word c, C_word closure, C_word k, C_word name)
     8943{
     8944  C_word done = C_SCHEME_FALSE;
     8945  LF_LIST *node;
     8946
     8947  if(c != 3) C_bad_argc(c, 3);
     8948
     8949  if (C_immediatep(name) || C_STRING_TYPE != C_header_bits(name))
     8950    barf(C_BAD_ARGUMENT_TYPE_ERROR, "##sys#dynamic-library-unload", name);
     8951
     8952  node = find_lf_list_node(C_c_string(name));
     8953  if(NULL != node) {
     8954    int ret = C_dynamic_library_close(node->module_handle);
     8955    unmake_lf_list_node(node);
     8956    if(0 == ret) done = C_SCHEME_TRUE;
     8957  }   
     8958
     8959  C_kontinue(k, done);
     8960}
    87378961
    87388962void C_ccall C_become(C_word c, C_word closure, C_word k, C_word table)
Note: See TracChangeset for help on using the changeset viewer.