Make (load-shared-object #f) portable (#753)

c/externs.h

@@ -445,6 +445,7 @@ extern ptr *S_get_call_arena(ptr tc);
 /* windows.c */
 extern INT S_getpagesize(void);
 extern ptr S_LastErrorString(void);
+extern HMODULE *S_enum_process_modules(void);
 extern void *S_ntdlopen(const char *path);
 extern void *S_ntdlsym(void *h, const char *s);
 extern ptr S_ntdlerror(void);

c/foreign.c

@@ -112,17 +112,42 @@ static ptr lookup_dynamic(const char *s, ptr tbl) {
     ptr p;
 
     for (p = tbl; p != Snil; p = Scdr(p)) {
+
 #ifdef HPUX
-        (void *)value = (void *)0; /* assignment to prevent compiler warning */
+        void *value = NULL;
         shl_t handle = (shl_t)ptr_to_addr(Scar(p));
 
-        if (shl_findsym(&handle, s, TYPE_PROCEDURE, (void *)&value) == 0)
+        /*
+         * With NULL path, use RTLD_SELF to act like dlopen(NULL, ...)
+         * See: https://docstore.mik.ua/manuals/hp-ux/en/B2355-60130/dlsym.3C.html
+         */
+        if (!handle)
+            handle = (void*)RTLD_SELF;
+
+        if (shl_findsym(&handle, s, TYPE_PROCEDURE, &value) == 0)
            return addr_to_ptr(proc2entry(value, NULL));
 #else /* HPUX */
         void *value;
-
-        value = dlsym(ptr_to_addr(Scar(p)), s);
-        if (value != (void *)0) return addr_to_ptr(value);
+        void *handle = ptr_to_addr(Scar(p));
+
+#ifdef WIN32
+        if (!handle) {
+            HMODULE *modules = S_enum_process_modules();
+            if (modules) {
+                for (HMODULE *m = modules; *m; ++m) {
+                    value = dlsym(*m, s);
+                    if (value != NULL) break;
+                }
+                free(modules);
+                if (value != NULL)
+                    return addr_to_ptr(value);
+            }
+        } else
+#endif /* WIN32 */
+        {
+            value = dlsym(handle, s);
+            if (value != NULL) return addr_to_ptr(value);
+        }
 #endif /* HPUX */
     }
 
@@ -229,9 +254,17 @@ static void load_shared_object(const char *path) {
 
     tc_mutex_acquire();
 
-    handle = dlopen(path, RTLD_NOW);
-    if (handle == (void *)NULL)
-        S_error2("", "(while loading ~a) ~a", Sstring_utf8(path, -1), s_dlerror());
+#if defined(WIN32) || defined(HPUX)
+    if (!path) {
+        handle = NULL;
+    } else
+#endif /* machine types */
+    {
+        handle = dlopen(path, RTLD_NOW);
+        if (handle == (void *)NULL)
+            S_error2("", "(while loading ~a) ~a", Sstring_utf8(path, -1), s_dlerror());
+    }
+
     S_foreign_dynamic = Scons(addr_to_ptr(handle), S_foreign_dynamic);
 
     tc_mutex_release();

c/windows.c

@@ -18,6 +18,7 @@
 
 #include "system.h"
 #include <objbase.h>
+#include <psapi.h>
 #include <io.h>
 #include <sys/stat.h>
 
@@ -49,6 +50,36 @@ void *S_ntdlopen(const char *path) {
   return r;
 }
 
+HMODULE *S_enum_process_modules(void) {
+    DWORD cur_num_bytes = 1024;
+    DWORD req_num_bytes;
+    HMODULE *modules = malloc(cur_num_bytes);
+
+    if (!modules)
+        return NULL;
+
+    for (;;) {
+        if (!EnumProcessModules(GetCurrentProcess(), modules, cur_num_bytes, &req_num_bytes))
+            return NULL;
+        req_num_bytes += sizeof *modules; // for sentinel NULL value
+        if (req_num_bytes <= cur_num_bytes)
+            break;
+        HMODULE *new_mod = realloc(modules, req_num_bytes);
+        if (!new_mod) {
+            free(modules);
+            return NULL;
+        }
+
+        modules = new_mod;
+        cur_num_bytes = req_num_bytes;
+    }
+
+    const size_t numel = req_num_bytes/sizeof *modules;
+    modules[numel - 1] = NULL;
+
+    return modules;
+}
+
 void *S_ntdlsym(void *h, const char *s) {
     return (void *)GetProcAddress(h, s);
 }

csug/foreign.stex

@@ -2670,8 +2670,9 @@ via one of the other methods described in this section.
 \endentryheader
 
 \noindent
-\var{path} must be a string.
-\scheme{load-shared-object} loads the shared object named by \var{path}.
+\var{path} must be a string or \scheme{#f}.
+If \var{path} is a string, \scheme{load-shared-object} loads the shared object
+named by \var{path}.
 Shared objects may be system libraries or files created from ordinary
 C programs.
 All external symbols in the shared object, along with external symbols
@@ -2685,6 +2686,26 @@ If \var{path} does not begin with a ``.'' or ``/'', the shared
 object is searched for in a default set of directories determined
 by the system.
 
+If \var{path} is \scheme{#f}, external symbols in the executable itself (if
+any), as well as those found in dependent shared objects, are also made
+available as foreign entries.
+Usually, executables do not export symbols, but can be instructed to do so with
+proper compilation flags.
+One may thus create an executable based on {\ChezScheme}, and have Scheme code
+access exported symbols from it and also from any shared object dynamically
+linked to it.
+
+Because {\ChezScheme} is usually dynamically linked to the operating system's C
+library, all built-in C library functions are also accessible after evaluation
+of \scheme{(load-shared-object #f)}.
+This provides a simple way to gain access to standard C functions (such as
+\var{memcpy} or \var{getenv}), which may be very convenient for Scheme programs
+intended to be portable across different systems.
+If {\ChezScheme} is statically linked however, the standard C functions may only
+be accessible in this manner if they are present in the executable and
+exported, otherwise the shared object containing the C library must be
+explicitly named; see below for examples for some platforms.
+
 On most Unix systems, \scheme{load-shared-object} is based on the
 system routine \scheme{dlopen}.
 %Under AIX, \scheme{load-shared-object} is based on the system routine
@@ -2701,6 +2722,7 @@ The name of the shared object varies from one system to another.
 % On Sun Sparc systems running Solaris 2.X or higher
 % running Digital Unix 2.X or higher, and SGI systems running IRIX 5.X
 % or higher
+
 On Linux systems:
 
 \schemedisplay

mats/foreign.ms

@@ -294,6 +294,18 @@
     )
    ])
 
+(mat load-shared-object-f
+  (equal?
+    (with-input-from-string
+      (separate-eval
+        '(begin
+           (printf "(~S " (foreign-entry? "memcpy"))
+           (load-shared-object #f)
+           (printf "~S)~%" (foreign-entry? "memcpy"))
+           (void)))
+      read)
+    '(#f #t)))
+
 (mat foreign-entry?
    (foreign-entry? "id")
    (foreign-entry? "idid")