summaryrefslogtreecommitdiffstats
path: root/dynl.c
diff options
context:
space:
mode:
authorDavid N. Welton <davidw@efn.org>1998-12-11 20:21:49 -0800
committerBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:25 -0800
commita47af30d2f0e96afcd1f14b1984575c359faa3d6 (patch)
tree2ed08ce2d757f917de7c3c7c04fd7e309f454c83 /dynl.c
parentf64b2806c1d66a1341bb8b1491f384169ab1d65f (diff)
parentdb04688faa20f3576257c0fe41752ec435beab9a (diff)
downloadscm-a47af30d2f0e96afcd1f14b1984575c359faa3d6.tar.gz
scm-a47af30d2f0e96afcd1f14b1984575c359faa3d6.zip
Import Debian changes 5c3-5debian/5c3-5
scm (5c3-5) frozen unstable; urgency=low * debian/rules chmod +x's bld.scm. Fixes #30521. scm (5c3-4) frozen unstable; urgency=low * Made bld.scm executable. Fixes #29578. scm (5c3-3) frozen unstable; urgency=low * -nw * Fixes #16762. * Fixes #18163. * Fixes #18164. * Fixes #23743. * Fixes #24098. * Fixes #24099. * Fixes #24547. scm (5c3-2) frozen unstable; urgency=low * Re-uploading for slink freeze. scm (5c3-1) unstable; urgency=low * New upstream version.
Diffstat (limited to 'dynl.c')
-rw-r--r--dynl.c241
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 */