diff options
Diffstat (limited to 'dynl.c')
-rw-r--r-- | dynl.c | 241 |
1 files changed, 214 insertions, 27 deletions
@@ -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 */ |