Import Upstream version 5c3upstream/5c3

1 files changed, 214 insertions, 27 deletions

diff --git a/dynl.c b/dynl.c
index 7e90a8a..8fcf7aa 100644
--- a/dynl.c
+++ b/dynl.c
@@ -121,7 +121,7 @@ SCM l_dyn_main_call(symb, shl, args)
   else dld_perror("DLDP");
   if (!i) listundefs();
   if (!func) {
-    must_free_argv(argv);
+    must_free_argv(argv, 0);
     ALLOW_INTS;
     dld_perror("DLD");
     return BOOL_F;
@@ -131,7 +131,7 @@ SCM l_dyn_main_call(symb, shl, args)
   i = (*func) ((int)ilength(args), argv);
 /*  *loc_loadpath = oloadpath; */
   DEFER_INTS;
-  must_free_argv(argv);
+  must_free_argv(argv, 0);
   ALLOW_INTS;
   return MAKINUM(0L+i);
 }
@@ -156,19 +156,22 @@ static iproc subr1s[] = {
 void init_dynl()
 {
 # ifndef RTL
+  if (!execpath) execpath = scm_find_executable();
   if ((!execpath) || dld_init(execpath)) {
     dld_perror("DLD:");
 /*    wta(CAR(progargs), "couldn't init", "dld"); */
     return;
   }
 # endif
-  init_iprocs(subr1s, tc7_subr_1);
-  make_subr(s_call, tc7_subr_2, l_dyn_call);
-  make_subr(s_main_call, tc7_lsubr_2, l_dyn_main_call);
-  add_feature("dld");
+  if (!dumped) {
+    init_iprocs(subr1s, tc7_subr_1);
+    make_subr(s_call, tc7_subr_2, l_dyn_call);
+    make_subr(s_main_call, tc7_lsubr_2, l_dyn_main_call);
+    add_feature("dld");
 # ifdef DLD_DYNCM
-  add_feature("dld:dyncm");
+    add_feature("dld:dyncm");
 # endif
+  }
 }
 #else
 
@@ -180,7 +183,7 @@ int prinshl(exp, port, writing)
      SCM exp; SCM port; int writing;
 {
   lputs("#<shl ", port);
-  intprint(CDR(exp), 16, port);
+  intprint(CDR(exp), -16, port);
   lputc('>', port);
   return 1;
 }
@@ -194,13 +197,13 @@ SCM l_dyn_link(fname)
   SCM z;
   shl_t shl;
   ASSERT(NIMP(fname) && STRINGP(fname), fname, ARG1, s_link);
+  NEWCELL(z);
   DEFER_INTS;
   shl = shl_load(CHARS(fname), BIND_DEFERRED , 0L);
   if (NULL==shl) {
     ALLOW_INTS;
     return BOOL_F;
   }
-  NEWCELL(z);
   SETCHARS(z, shl);
   CAR(z) = tc16_shl;
   ALLOW_INTS;
@@ -252,7 +255,7 @@ SCM l_dyn_main_call(symb, shl, args)
   i = (*func) ((int)ilength(args), argv);
 /*  *loc_loadpath = oloadpath; */
   DEFER_INTS;
-  must_free_argv(argv);
+  must_free_argv(argv, 0);
   ALLOW_INTS;
   return MAKINUM(0L+i);
 }
@@ -275,11 +278,13 @@ static iproc subr1s[] = {
 	{0, 0}};
 void init_dynl()
 {
-  tc16_shl = newsmob(&shlsmob);
-  init_iprocs(subr1s, tc7_subr_1);
-  make_subr(s_call, tc7_subr_2, l_dyn_call);
-  make_subr(s_main_call, tc7_lsubr_2, l_dyn_main_call);
-  add_feature("shl");
+  if (!dumped) {
+    tc16_shl = newsmob(&shlsmob);
+    init_iprocs(subr1s, tc7_subr_1);
+    make_subr(s_call, tc7_subr_2, l_dyn_call);
+    make_subr(s_main_call, tc7_lsubr_2, l_dyn_main_call);
+    add_feature("shl");
+  }
 }
 # endif
 #endif
@@ -337,7 +342,9 @@ SCM dynl(dir, symbol, fname)
 
 void init_dynl()
 {
+  if (!dumped) {
   make_subr(s_dynl, tc7_subr_3, dynl);
+  }
 }
 #endif
 
@@ -369,7 +376,7 @@ int prinshl(exp, port, writing)
 	SCM exp; SCM port; int writing;
 {
   lputs("#<shl ", port);
-  intprint(CDR(exp), 16, port);
+  intprint(CDR(exp), -16, port);
   lputc('>', port);
   return 1;
 }
@@ -384,13 +391,21 @@ SCM l_dyn_link(fname)
   void *handle;
   if FALSEP(fname) return fname;
   ASSERT(NIMP(fname) && STRINGP(fname), fname, ARG1, s_link);
+  NEWCELL(z);
   DEFER_INTS;
   handle = dlopen(CHARS(fname), DLOPEN_MODE);
   if (NULL==handle) {
-    ALLOW_INTS;
+    if (verbose > 2) {
+      char *dlr = dlerror();
+      ALLOW_INTS;
+      if (dlr) {
+	lputs(s_link, cur_errp);
+	lputs(": ", cur_errp);
+	lputs(dlr, cur_errp);
+	newline(cur_errp);
+      }}
     return BOOL_F;
   }
-  NEWCELL(z);
   SETCHARS(z, handle);
   CAR(z) = tc16_shl;
   ALLOW_INTS;
@@ -408,9 +423,14 @@ SCM l_dyn_call(symb, shl)
   DEFER_INTS;
   func = dlsym(SHL(shl), CHARS(symb));
   if (!func) {
-    const char *dlr = dlerror();
+    char *dlr = dlerror();
     ALLOW_INTS;
-    if (dlr) puts(dlr);
+    if (dlr) {
+      lputs(s_call, cur_errp);
+      lputs(": ", cur_errp);
+      lputs(dlr, cur_errp);
+      newline(cur_errp);
+    }
     return BOOL_F;
   }
   ALLOW_INTS;
@@ -432,9 +452,14 @@ SCM l_dyn_main_call(symb, shl, args)
   DEFER_INTS;
   func = dlsym(SHL(shl), CHARS(symb));
   if (!func) {
-    const char *dlr = dlerror();
+    char *dlr = dlerror();
     ALLOW_INTS;
-    if (dlr) puts(dlr);
+    if (dlr) {
+      lputs(s_main_call, cur_errp);
+      lputs(": ", cur_errp);
+      lputs(dlr, cur_errp);
+      newline(cur_errp);
+    }
     return BOOL_F;
   }
   argv = makargvfrmstrs(args, s_main_call);
@@ -468,10 +493,172 @@ static iproc subr1s[] = {
 
 void init_dynl()
 {
-  tc16_shl = newsmob(&shlsmob);
-  init_iprocs(subr1s, tc7_subr_1);
-  make_subr(s_call, tc7_subr_2, l_dyn_call);
-  make_subr(s_main_call, tc7_lsubr_2, l_dyn_main_call);
-  add_feature("sun-dl");
+  if (!dumped) {
+    tc16_shl = newsmob(&shlsmob);
+    init_iprocs(subr1s, tc7_subr_1);
+    make_subr(s_call, tc7_subr_2, l_dyn_call);
+    make_subr(s_main_call, tc7_lsubr_2, l_dyn_main_call);
+    add_feature("sun-dl");
+  }
 }
 #endif	/* SUN_DL */
+
+#ifdef macintosh
+
+# include <CodeFragments.h>
+# include <Errors.h>
+
+# define SHL(obj) ((void*)CDR(obj))
+
+sizet frshl(ptr)
+	CELLPTR ptr;
+{
+# if 0
+  /* Should freeing a shl close and possibly unmap the object file it */
+  /* refers to? */
+  if(SHL(ptr))
+    dlclose(SHL(ptr));
+# endif
+  return 0;
+}
+
+int prinshl(exp, port, writing)
+	SCM exp; SCM port; int writing;
+{
+  lputs("#<shl ", port);
+  intprint(CDR(exp), 16, port);
+  lputc('>', port);
+  return 1;
+}
+int tc16_shl;
+static smobfuns shlsmob = {mark0, frshl, prinshl};
+
+static char s_link[] = "dyn:link", s_call[] = "dyn:call";
+SCM l_dyn_link(fname)
+	SCM fname;
+{
+  OSErr err;
+  SCM z;
+  void *handle;
+  Str63 libName;
+  CFragConnectionID connID;
+  Ptr mainAddr;
+  Str255 errMessage;
+
+  if FALSEP(fname) return fname;
+  ASSERT(NIMP(fname) && STRINGP(fname), fname, ARG1, s_link);
+  NEWCELL(z);
+  DEFER_INTS;
+  strcpy((char *)libName,  CHARS(fname));
+  c2pstr((char *)libName);
+  err = GetSharedLibrary (libName, kCompiledCFragArch, kReferenceCFrag,
+			  &connID, &mainAddr, errMessage);
+
+  if (err!=noErr) {
+    ALLOW_INTS;
+    return BOOL_F;
+  }
+  SETCHARS(z, (void *)connID);
+  CAR(z) = tc16_shl;
+  ALLOW_INTS;
+  /*  linkpath = fname; */
+  return z;
+}
+
+SCM l_dyn_call(symb, shl)
+	SCM symb, shl;
+{
+  void (*func)() = 0;
+  OSErr err;
+  CFragSymbolClass symClass;
+  Str255 symName;
+  
+  /*  SCM oloadpath = *loc_loadpath; */
+  ASSERT(NIMP(symb) && STRINGP(symb), symb, ARG1, s_call);
+  ASSERT(NIMP(shl) && CAR(shl)==tc16_shl, shl, ARG2, s_call);
+  DEFER_INTS;
+  
+  strcpy((char *)symName, CHARS(symb));
+  c2pstr((char *)symName);
+  err = FindSymbol((CFragConnectionID)SHL(shl), symName,
+		   (Ptr *)&func, &symClass);
+  if (err!=noErr /* || symClass != kCodeCFragSymbol */) {
+    ALLOW_INTS;
+    if (err == cfragConnectionIDErr) puts("Invalid library connection.");
+    if (err == cfragNoSymbolErr) puts("Symbol not found.");
+    return BOOL_F;
+  }
+  ALLOW_INTS;
+  /*  *loc_loadpath = linkpath; */
+  (*func) ();
+  /*  *loc_loadpath = oloadpath; */
+  return BOOL_T;
+}
+static char s_main_call[] = "dyn:main-call";
+SCM l_dyn_main_call(symb, shl, args)
+	SCM symb, shl, args;
+{
+  int i;
+  int (*func)P((int argc, char **argv)) = 0; 
+  char **argv;
+  OSErr err;
+  CFragSymbolClass symClass;
+  Str255 symName;
+  
+  /*  SCM oloadpath = *loc_loadpath; */
+  ASSERT(NIMP(symb) && STRINGP(symb), symb, ARG1, s_main_call);
+  ASSERT(NIMP(shl) && CAR(shl)==tc16_shl, shl, ARG2, s_main_call);
+  DEFER_INTS;
+  strcpy((char *)symName, CHARS(symb));
+  c2pstr((char *)symName);
+  err = FindSymbol((CFragConnectionID)SHL(shl), symName,
+		   (Ptr *)&func, &symClass);
+  if (err!=noErr || symClass != kCodeCFragSymbol) {
+    ALLOW_INTS;
+    if (err == cfragConnectionIDErr) puts("Invalid library connection.");
+    if (err == cfragNoSymbolErr) puts("Symbol not found.");
+    return BOOL_F;
+  }
+  argv = makargvfrmstrs(args, s_main_call);
+  ALLOW_INTS;
+  /*  *loc_loadpath = linkpath; */
+  i = (*func) ((int)ilength(args), argv);
+  /*  *loc_loadpath = oloadpath; */
+  DEFER_INTS;
+  must_free_argv(argv, 0);
+  ALLOW_INTS;
+  return MAKINUM(0L+i);
+}
+
+static char s_unlink[] = "dyn:unlink";
+SCM l_dyn_unlink(shl)
+	SCM shl;
+{
+  OSErr status;
+  CFragConnectionID connID;
+
+  ASSERT(NIMP(shl) && CAR(shl)==tc16_shl, shl, ARG1, s_unlink);
+  DEFER_INTS;
+  connID = (CFragConnectionID)SHL(shl);
+  status = CloseConnection(&connID);
+  SETCHARS(shl, NULL);
+  ALLOW_INTS;
+  if (status!=noErr) return BOOL_T;
+  return BOOL_F;
+}
+static iproc subr1s[] = {
+  {s_link, l_dyn_link},
+  {s_unlink, l_dyn_unlink},
+  {0, 0}};
+
+void init_dynl()
+{
+  if (!dumped) {
+    tc16_shl = newsmob(&shlsmob);
+    init_iprocs(subr1s, tc7_subr_1);
+    make_subr(s_call, tc7_subr_2, l_dyn_call);
+    make_subr(s_main_call, tc7_lsubr_2, l_dyn_main_call);
+    add_feature("mac-dl");
+  }
+}
+#endif	/* MACOS */