Major cleanup: eliminate dead code from HP-UX and AIX; simplify

interfaces; generate meaningful errors when possible using new
error-signalling mechanism.

diff --git a/v7/src/microcode/pruxdld.c b/v7/src/microcode/pruxdld.c
index 687f9f9019118cce7f559d3b15418f539ec1a5c5..9d41d13ba4ac976cc850e48a84302cf5f08985e4 100644 (file)
--- a/v7/src/microcode/pruxdld.c
+++ b/v7/src/microcode/pruxdld.c
@@ -1,8 +1,8 @@
 /* -*-C-*-
 
-$Id: pruxdld.c,v 1.13 2000/12/05 21:23:47 cph Exp $
+$Id: pruxdld.c,v 1.14 2001/03/08 18:01:45 cph Exp $
 
-Copyright (c) 1993-2000 Massachusetts Institute of Technology
+Copyright (c) 1993-2001 Massachusetts Institute of Technology
 
 This program is free software; you can redistribute it and/or modify
 it under the terms of the GNU General Public License as published by
@@ -19,12 +19,7 @@ along with this program; if not, write to the Free Software
 Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 */
 
-/* This file contains the interface to a unix dynamic loader.
-   It has been tried under HP-UX, SunOS (4.1.?), and Alpha OSF 1.
- */
-
-/* This #if covers the entire file. */
-#ifndef DISABLE_DLD_SUPPORT
+/* This file contains the interface to the unix dynamic loader.  */
 
 #include "scheme.h"
 #include "prims.h"
@@ -32,211 +27,86 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 #include "syscall.h"
 #include "os.h"
 \f
-#if defined(_AIX)
-
-#include <sys/ldr.h>
-
-typedef int * dyn_load_handle_t;
-
-#define TYPE_PROCEDURE 0
-#define TYPE_DATA      1
-#define TYPE_UNDEFINED 2
-
-#define PROG_HANDLE ((dyn_load_handle_t) NULL)
-
-static dyn_load_handle_t
-DEFUN (dyn_load, (path), char * path)
-{
-  extern int EXFUN (main, (int, char *, char **));
-  dyn_load_handle_t result = (load (path, L_NOAUTODEFER, ((char *) NULL)));
-  if (result != ((dyn_load_handle_t) NULL))
-    loadbind (0, main, result);
-  return (result);
-}
-
-static int
-DEFUN (dyn_lookup, (handle, symbol, type, result),
-       dyn_load_handle_t * handle
-       AND char * symbol
-       AND int type
-       AND PTR * result)
-{
-  /* This is bogus */
-  * result = ((PTR) (* handle));
-  return (0);
-}
-\f
-#else /* not _AIX */
-#if defined(__HPUX__)
-
-#include <dl.h>
-
-#ifndef DYNAMIC_PATH
-# define DYNAMIC_PATH 0
-#endif
-
-typedef shl_t dyn_load_handle_t;
-
-static dyn_load_handle_t
-DEFUN (dyn_load, (path), char * path)
-{
-  return (shl_load (path,
-                   (BIND_IMMEDIATE | BIND_NONFATAL | DYNAMIC_PATH),
-                   0));
-}
-
-static int 
-DEFUN (dyn_lookup, (handle, symbol, type, result),
-       dyn_load_handle_t * handle
-       AND char * symbol
-       AND int type
-       AND PTR * result)
-{
-#if !(defined(hp9000s300) || defined(__hp9000s300))
-  return (shl_findsym (handle, symbol, type, result));
-#else
-  /* External symbols on the 300s often have underscores.
-     Look both ways.
-   */
-  char * temp;
-  int retval = (shl_findsym (handle, symbol, type, result));
-
-  if (retval != -1)
-    return (retval);
-  temp = ((char *) (malloc (2 + (strlen (symbol)))));
-  if (temp == ((char *) NULL))
-    return (-1);
-  *temp = '_';
-  strcpy (temp + 1, symbol);
-  retval = (shl_findsym (handle, temp, type, result));
-  free (temp);
-  return (retval);
-#endif
-}
-\f
-#else /* not __HPUX__ */
+#ifdef __linux__
 
 #include <dlfcn.h>
 
-#define TYPE_PROCEDURE 0
-#define TYPE_DATA      1
-#define TYPE_UNDEFINED 2
-
-typedef void * dyn_load_handle_t;
-
-#define PROG_HANDLE ((dyn_load_handle_t) NULL)
-
-static dyn_load_handle_t
-DEFUN (dyn_load, (path), char * path)
+static unsigned long
+DEFUN (dld_load, (path), CONST char * path)
 {
-  dyn_load_handle_t result = (dlopen (path, RTLD_LAZY | RTLD_GLOBAL));
-
-#if 0
-  if (result == ((dyn_load_handle_t) NULL))
-    fprintf (stderr, "\ndlopen: %s.\n", (dlerror ()));
-#endif
-
-  return (result);
+  void * handle = (dlopen (path, (RTLD_LAZY | RTLD_GLOBAL)));
+  if (handle == 0)
+    {
+      SCHEME_OBJECT v = (allocate_marked_vector (TC_VECTOR, 3, 1));
+      VECTOR_SET (v, 0, (LONG_TO_UNSIGNED_FIXNUM (ERR_IN_SYSTEM_CALL)));
+      VECTOR_SET (v, 1, (char_pointer_to_string ("dlopen")));
+      VECTOR_SET (v, 2, (char_pointer_to_string (dlerror ())));
+      error_with_argument (v);
+    }
+  return ((unsigned long) handle);
 }
 
-static int
-DEFUN (dyn_lookup, (handle, symbol, type, result),
-       dyn_load_handle_t * handle
-       AND char * symbol
-       AND int type
-       AND PTR * result)
+static unsigned long
+DEFUN (dld_lookup, (handle, symbol), unsigned long handle AND char * symbol)
 {
-  * result = (dlsym ((* handle), symbol));
-  return (((* result) == ((PTR) NULL))
-         ? -1
-         : 0);
+  CONST char * old_error = (dlerror ());
+  void * address = (dlsym (((void *) handle), symbol));
+  CONST char * new_error = (dlerror ());
+  if ((address == 0) && (new_error != old_error))
+    {
+      SCHEME_OBJECT v = (allocate_marked_vector (TC_VECTOR, 3, 1));
+      VECTOR_SET (v, 0, (LONG_TO_UNSIGNED_FIXNUM (ERR_IN_SYSTEM_CALL)));
+      VECTOR_SET (v, 1, (char_pointer_to_string ("dlsym")));
+      VECTOR_SET (v, 2, (char_pointer_to_string (new_error)));
+      error_with_argument (v);
+    }
+  return ((unsigned long) address);
 }
 
-#endif /* __HPUX__ */
-#endif /* _AIX */
+#endif /* __linux__ */
 \f
 DEFINE_PRIMITIVE ("LOAD-OBJECT-FILE", Prim_load_object_file, 1, 1,
-                 "(load-object-file lib-file)")
+                 "(FILENAME)\n\
+Load the shared library FILENAME and return a handle for it.")
 {
-  extern int errno;
-  dyn_load_handle_t prim_lib_handle;
   PRIMITIVE_HEADER (1);
-
-  prim_lib_handle = (dyn_load (STRING_ARG (1)));
-  if (prim_lib_handle == ((dyn_load_handle_t) NULL))
-    error_system_call (errno, syscall_dld);
-  PRIMITIVE_RETURN (long_to_integer ((long) prim_lib_handle));
+  PRIMITIVE_RETURN (ulong_to_integer (dld_load (STRING_ARG (1))));
 }
 
-static short dyn_load_types [] =
-{
-  TYPE_PROCEDURE,
-  TYPE_DATA,
-  TYPE_UNDEFINED
-};
-
 DEFINE_PRIMITIVE ("OBJECT-LOOKUP-SYMBOL", Prim_object_lookup_symbol, 3, 3,
-                 "(object-lookup-symbol handle sym type)")
+                 "(HANDLE SYMBOL TYPE)\n\
+Look up SYMBOL, a Scheme string, in the dynamically-loaded file\n\
+referenced by HANDLE.  TYPE is obsolete and must be specified as zero.
+Returns the symbol's address, or signals an error if no such symbol.")
 {
-  char * sym;
-  short type;
-  PTR result;
-  dyn_load_handle_t prim_lib_handle, * arg_handle;
   PRIMITIVE_HEADER (3);
-
-  switch (ARG_REF (1))
-  {
-    case SHARP_F:
-      prim_lib_handle = PROG_HANDLE;
-      arg_handle = & prim_lib_handle;
-      break;
-
-    case SHARP_T:
-      arg_handle = ((dyn_load_handle_t *) NULL);
-      break;
-
-    default:
-      prim_lib_handle = ((dyn_load_handle_t) (arg_integer (1)));
-      arg_handle = & prim_lib_handle;
-      break;
-  }
-
-  sym = (STRING_ARG (2));
-  type = dyn_load_types [arg_index_integer (3, ((sizeof (dyn_load_types))
-                                               / (sizeof (short))))];
-
-  if ((dyn_lookup (arg_handle, sym, type, & result)) == -1)
-    PRIMITIVE_RETURN (SHARP_F);
-  PRIMITIVE_RETURN (long_to_integer ((long) result));
+  if ((ARG_REF (3)) != FIXNUM_ZERO)
+    error_wrong_type_arg (3);
+  PRIMITIVE_RETURN
+    (ulong_to_integer
+     (dld_lookup ((arg_ulong_integer (1)), (STRING_ARG (2)))));
 }
 
 DEFINE_PRIMITIVE ("INVOKE-C-THUNK", Prim_invoke_C_thunk, 1, 1,
-                 "(address)\n\
-Treat the integer argument as the address of a C procedure of no\n\
-arguments that returns a long.  Invoke it, and return\n\
-the corresponding Scheme integer.")
+                 "(ADDRESS)\n\
+Treat ADDRESS, a Scheme integer corresponding to a C unsigned long, as\n\
+the address of a C procedure of no arguments that returns an unsigned\n\
+long.  Invoke it, and return the corresponding Scheme integer.")
 {
-  long address;
-  long result;
-  long EXFUN ((* thunk), (void));
   PRIMITIVE_HEADER (1);
-  
-  address = ((long) (arg_integer (1)));
-  thunk = ((long EXFUN ((*), (void))) address);
-  result = ((* thunk) ());
-  PRIMITIVE_RETURN (long_to_integer (result));
+  PRIMITIVE_RETURN
+    (ulong_to_integer
+     ((* ((unsigned long EXFUN ((*), (void))) (arg_ulong_integer (1))))
+      ()));
 }
 
 DEFINE_PRIMITIVE ("ADDRESS-TO-STRING", Prim_address_to_string, 1, 1,
-                 "(address)\n\
-Treat the integer argument as a C (char *) pointer.\n\
-Construct the corresponding Scheme string.")
+                 "(ADDRESS)\n\
+Treat ADDRESS, a Scheme integer corresponding to a C unsigned long, as\n\
+a C char * pointer.  Allocate and return a Scheme string with the same\n\
+contents.")
 {
-  long address;
   PRIMITIVE_HEADER (1);
-
-  address = ((long) (arg_integer (1)));
-  PRIMITIVE_RETURN (char_pointer_to_string ((unsigned char *) address));
+  PRIMITIVE_RETURN
+    (char_pointer_to_string ((unsigned char *) (arg_ulong_integer (1))));
 }
-
-#endif /* not DISABLE_DLD_SUPPORT */