00001
00002
00003
00004
00005
00006
00007
00008
00009 static char *rcsid="@(#)$Id$";
00010
00011 #include <signal.h>
00012 #include <ctype.h>
00013 #include <sys/file.h>
00014 #include <fcntl.h>
00015 #include <dlfcn.h>
00016 #if i86pc
00017 #include <link.h>
00018 #endif
00019
00020 #if alpha
00021 #undef MAX
00022 #undef MIN
00023 #undef VMAX
00024 #undef VMIN
00025 #endif
00026 #include "../c/eus.h"
00027
00028 extern int errno;
00029 extern pointer openfile();
00030 extern pointer makemodule(context *, int);
00031
00032
00033
00034
00035
00036
00037
00038
00039
00040
00041 pointer SRCLOAD(ctx,n,argv)
00042 register context *ctx;
00043 int n;
00044 pointer argv[];
00045 { pointer in,form;
00046 ckarg(1);
00047 in=openfile(ctx,(char *)argv[0]->c.str.chars,O_RDONLY,0,256);
00048 vpush(in);
00049 if (in==0) error(E_OPENFILE);
00050 form=reader(ctx,in,NIL);
00051 while (form!=(pointer)EOF){
00052
00053
00054 eval(ctx,form);
00055 form=reader(ctx,in,NIL);
00056 }
00057 closestream(in);
00058 vpop();
00059 return(NIL);}
00060
00061
00062
00063
00064
00065
00066
00067
00068
00069
00070
00071
00072
00073
00074
00075
00076
00077
00078 #define MAX_SYSTEM_MODULES 100
00079 int module_count=0;
00080 struct {
00081 pointer (*entry_func)();
00082 char *module_name;}
00083 module_initializers[MAX_SYSTEM_MODULES];
00084
00085
00086 void add_module_initializer(name, entry)
00087 char *name;
00088 pointer (*entry)();
00089 {
00090
00091 if (module_count>=MAX_SYSTEM_MODULES) error(E_USER,(pointer)"too many system modules");
00092 module_initializers[module_count].module_name= name;
00093 module_initializers[module_count].entry_func= entry;
00094 module_count++;}
00095
00096
00097 void exec_module_initializers(ctx)
00098 register context *ctx;
00099 { eusinteger_t i, addr;
00100 pointer (*initfunc)(context *, int, pointer *);
00101 pointer mod;
00102 for (i=0; i< module_count; i++) {
00103 printf("executing init: %s at %p...",
00104 module_initializers[i].module_name,
00105 module_initializers[i].entry_func);
00106 fflush(stdout);
00107 initfunc=module_initializers[i].entry_func;
00108 mod=makemodule(ctx,0);
00109 vpush(mod);
00110 breakck;
00111 if (initfunc) {
00112 addr = (eusinteger_t)initfunc;
00113 addr= addr>>2;
00114 mod->c.ldmod.entry=makeint(addr);
00115 #if ARM
00116 mod->c.ldmod.entry2=makeint(initfunc);
00117 #endif
00118 mod->c.ldmod.subrtype=SUBR_ENTRY;
00119 (*initfunc)(ctx,1, &mod); }
00120 vpop();
00121 printf(" ok\n");}
00122 module_count=0;}
00123
00124 #if Solaris2 && !GCC
00125 pointer list_module_initializers(ctx,initnames)
00126 context *ctx;
00127 pointer initnames;
00128 { int i, addr;
00129 pointer (*initfunc)(int, pointer *);
00130 pointer mod, modname, p;
00131 for (i=0; i<module_count; i++) {
00132 initfunc=module_initializers[i].entry_func;
00133 modname=makestring(module_initializers[i].module_name,
00134 strlen(module_initializers[i].module_name));
00135 vpush(modname);
00136 addr= (int)initfunc; addr >>=2;
00137 mod=makemodule(ctx,0);
00138 mod->c.ldmod.codevec=makeint(0);
00139 mod->c.ldmod.entry=makeint(addr);
00140 mod->c.ldmod.subrtype=SUBR_FUNCTION;
00141 if (debug)
00142 printf("collecting init: %s at %x module at %x\n",
00143 module_initializers[i].module_name,
00144 module_initializers[i].entry_func, mod);
00145 p=cons(ctx,mod, NIL);
00146 p=cons(ctx,vpop(), p);
00147 vpush(p);}
00148 p=(pointer)stacknlist(ctx,module_count);
00149 module_count=0;
00150 return(p);}
00151
00152 #else
00153 pointer list_module_initializers(ctx, initnames)
00154 context *ctx;
00155 pointer initnames;
00156 { int i;
00157 eusinteger_t addr;
00158 pointer (*initfunc)(int, pointer *);
00159 pointer mod, modname, p;
00160 void *dlhandle;
00161 char namebuf[256];
00162
00163 dlhandle=dlopen(0,RTLD_LAZY);
00164 if (dlhandle==NULL) {
00165 fprintf(stderr, "cannot dlopen self\n"); exit(2);}
00166 module_count=0;
00167 while (iscons(initnames)) {
00168
00169 initfunc= dlsym(dlhandle, (char *)ccar(initnames)->c.str.chars);
00170 if (initfunc==NULL) {
00171 sprintf(namebuf,"___%s",ccar(initnames)->c.str.chars);
00172 initfunc=dlsym(dlhandle, namebuf);}
00173
00174 if (initfunc) {
00175
00176 modname=ccar(initnames);
00177 vpush(modname);
00178 addr= (eusinteger_t)initfunc; addr >>=2;
00179 mod=makemodule(ctx,0);
00180 mod->c.ldmod.codevec=makeint(0);
00181 mod->c.ldmod.entry=makeint(addr);
00182 #if ARM
00183 mod->c.ldmod.entry2=makeint(initfunc);
00184 #endif
00185 mod->c.ldmod.subrtype=SUBR_FUNCTION;
00186 p=cons(ctx,mod, NIL);
00187 p=cons(ctx,vpop(), p);
00188 vpush(p); module_count++;
00189 }
00190
00191
00192 initnames=ccdr(initnames); }
00193 p=(pointer)stacknlist(ctx,module_count);
00194 module_count=0;
00195 return(p);}
00196
00197 pointer list_module_initializers2(ctx, n, argv)
00198 register context *ctx;
00199 int n;
00200 pointer *argv;
00201 { int i;
00202 eusinteger_t addr;
00203 pointer (*initfunc)(int, pointer *);
00204 pointer mod, modname, initnames, p;
00205 void *dlhandle;
00206 char namebuf[256];
00207
00208 ckarg(2);
00209 if (!isldmod(argv[0])) error(E_USER,(pointer)"not a LOAD-MODULE");
00210 if (!iscons(argv[1])) error(E_NOLIST);
00211 #if x86_64
00212 dlhandle=(void *)((eusinteger_t)(argv[0]->c.ldmod.handle) & ~3L);
00213 #else
00214 dlhandle=(void *)((eusinteger_t)(argv[0]->c.ldmod.handle) & ~3);
00215 #endif
00216 initnames=argv[1];
00217 module_count=0;
00218 if (dlhandle==NULL) error(E_USER,(pointer)"This module was not loaded");
00219
00220 while (iscons(initnames)) {
00221 initfunc= dlsym(dlhandle, (char *)ccar(initnames)->c.str.chars);
00222 if (initfunc==NULL) {
00223 sprintf(namebuf,"___%s",ccar(initnames)->c.str.chars);
00224 initfunc=dlsym(dlhandle, namebuf);}
00225
00226 if (initfunc) {
00227 modname=ccar(initnames);
00228 vpush(modname);
00229 addr= (eusinteger_t)initfunc; addr >>=2;
00230 mod=makemodule(ctx,0);
00231 mod->c.ldmod.codevec=makeint(0);
00232 mod->c.ldmod.entry=makeint(addr);
00233 #if ARM
00234 mod->c.ldmod.entry2=makeint(initfunc);
00235 #endif
00236 mod->c.ldmod.subrtype=SUBR_FUNCTION;
00237 p=cons(ctx,mod, NIL);
00238 p=cons(ctx,vpop(), p);
00239 vpush(p); module_count++;}
00240 else {
00241 printf("%s not loaded\n", ccar(initnames)->c.str.chars); }
00242 initnames=ccdr(initnames); }
00243 p=(pointer)stacknlist(ctx,module_count);
00244 module_count=0;
00245 return(p);}
00246 #endif
00247
00248 pointer build_quote_vector(ctx,size, strings)
00249 register context *ctx;
00250 int size;
00251 char *strings[];
00252 { pointer qvec, p, qstring, qstream;
00253 int i, k;
00254 qvec=makevector(C_VECTOR,size);
00255 vpush(qvec);
00256 qstream=(pointer)mkstream(ctx,K_IN,makestring("",0));
00257 vpush(qstream);
00258 for (i=0; i<size; i++) {
00259 k=strlen((char *)strings[i]);
00260 qstring=makestring(strings[i], k);
00261
00262 pointer_update(qstream->c.stream.buffer,qstring);
00263 qstream->c.stream.count=makeint(0);
00264 qstream->c.stream.tail=makeint(k);
00265 pointer_update(qvec->c.vec.v[i],reader(ctx,qstream, NIL));}
00266 vpop();
00267 vpop();
00268
00269 #ifdef SAFETY
00270 take_care(qvec);
00271 #endif
00272 return(qvec);}
00273
00274 pointer eval_c_strings(ctx,size, strings)
00275 register context *ctx;
00276 int size;
00277 const char *strings[];
00278 { pointer p, qstream, qstring;
00279 int i, k, total_length;
00280 char *s;
00281 byte *d;
00282
00283 total_length=size;
00284 for (i=0; i<size; i++) { total_length += strlen(strings[i]); }
00285 qstring = makebuffer(total_length);
00286 vpush(qstring);
00287 d=qstring->c.str.chars;
00288 for (i=0; i<size; i++) {
00289 s=(char *)strings[i];
00290 while (*s) *d++ = *s++;
00291 *d++= '\n';}
00292
00293 qstream=(pointer)mkstream(ctx,K_IN, qstring);
00294 vpush(qstream);
00295 qstream->c.stream.tail=makeint(total_length);
00296 while ((p=reader(ctx,qstream, NIL))!= (pointer)(-1)) {
00297 if (debug) { prinx(ctx,p,STDOUT); terpri(STDOUT); }
00298 p=eval(ctx,p);}
00299 vpop();
00300 vpop();
00301 return(p);}
00302
00303 pointer FIND_ENTRY(ctx,n,argv)
00304 register context *ctx;
00305 int n;
00306 pointer argv[];
00307 { pointer entry, mod;
00308 char *entry_string;
00309 extern pointer sysmod;
00310
00311 ckarg2(1,2);
00312 if (n==2) mod=argv[1];
00313 else mod=sysmod;
00314 if (!isldmod(mod)) error(E_USER,(pointer)"not a LOAD-MODULE");
00315 entry_string=(char *)get_string(argv[0]);
00316 #if x86_64
00317 entry=(pointer)dlsym((void *)((eusinteger_t)(mod->c.ldmod.handle) & ~3L), entry_string);
00318 #else
00319 entry=(pointer)dlsym((void *)((eusinteger_t)(mod->c.ldmod.handle) & ~3), entry_string);
00320 #endif
00321 if (entry==NULL) return(NIL);
00322 else return(makeint((eusinteger_t)entry>>2));}
00323
00324 pointer FIND_ENTRY2(ctx,n,argv)
00325 register context *ctx;
00326 int n;
00327 pointer argv[];
00328 { pointer entry, mod, e=NIL;
00329 char *entry_string;
00330 extern pointer sysmod;
00331
00332 ckarg2(1,2);
00333 if (n==2) mod=argv[1];
00334 else mod=sysmod;
00335 if (!isldmod(mod)) error(E_USER,(pointer)"not a LOAD-MODULE");
00336 entry_string=(char *)get_string(argv[0]);
00337 #if x86_64
00338 entry=(pointer)dlsym((void *)((eusinteger_t)(mod->c.ldmod.handle) & ~3L), entry_string);
00339 #else
00340 entry=(pointer)dlsym((void *)((eusinteger_t)(mod->c.ldmod.handle) & ~3), entry_string);
00341 #endif
00342 if (entry==NULL) return(NIL);
00343 else {
00344 e=cons(ctx,makeint((eusinteger_t)entry),e);
00345 e=cons(ctx,makeint((eusinteger_t)entry>>2),e);
00346 return(e);}}
00347
00348 extern pointer sysmod;
00349
00350 pointer SYSMOD()
00351 { return(sysmod);}
00352
00353 pointer UNBINLOAD(ctx,n,argv)
00354 register context *ctx;
00355 int n;
00356 pointer *argv;
00357 { register pointer mod=argv[0];
00358 register int stat;
00359 ckarg(1);
00360 if (!isldmod(mod)) error(E_USER,(pointer)"not a compiled-module");
00361 #if x86_64
00362 stat=dlclose((void *)((eusinteger_t)(mod->c.ldmod.handle) & ~3L));
00363 #else
00364 stat=dlclose((void *)((eusinteger_t)(mod->c.ldmod.handle) & ~3));
00365 #endif
00366 if (stat) return(makeint(-errno));
00367 else return(T);}
00368
00369 pointer BINLOAD(ctx,n,argv)
00370 register context *ctx;
00371 int n;
00372 pointer *argv;
00373 { char *binfn, *quofn;
00374 char *entry;
00375 int binfd,size,newsize,stat,i=0,l,s;
00376 pointer mod,quostrm,qvec;
00377 byte *loadaddress;
00378 pointer (*initfunc)(context *, int, pointer *);
00379 int data_align=0;
00380 eusinteger_t dlhandle, addr;
00381
00382 ckarg2(1,2);
00383 binfn= (char *)get_string(argv[0]);
00384 if (n==2) {
00385 if (argv[1]==NIL) entry=NULL;
00386 else entry=(char *)get_string(argv[1]);}
00387 else entry=NULL;
00388
00389 dlhandle=(eusinteger_t)dlopen(binfn, RTLD_LAZY);
00390 if (dlhandle == 0) {
00391 fprintf(stderr,"BINLOAD cannot dlopen: %s\n", dlerror());
00392 return(NIL);}
00393 initfunc=NULL;
00394 if (entry) {
00395 initfunc=(pointer (*)(context *, int, pointer *))dlsym((void *)dlhandle, entry);
00396 if (initfunc==NULL)
00397 initfunc=(pointer (*)(context *, int, pointer *))dlsym((void *)dlhandle, &entry[3]);
00398
00399 }
00400 mod=makemodule(ctx,0);
00401 pointer_update(mod->c.ldmod.objname,argv[0]);
00402 mod->c.ldmod.handle=makeint(dlhandle>>2);
00403 vpush(mod);
00404
00405
00406 breakck;
00407 if (initfunc) {
00408 addr=(eusinteger_t)initfunc; addr >>=2;
00409 mod->c.ldmod.codevec=makeint(0);
00410 mod->c.ldmod.entry=makeint(addr);
00411 #if ARM
00412 mod->c.ldmod.entry2=makeint(initfunc);
00413 #endif
00414 mod->c.ldmod.subrtype=SUBR_FUNCTION;
00415 (*initfunc)(ctx, 1, &mod); }
00416 else if (debug) fprintf(stderr,";; no initializer\n");
00417 return(vpop());
00418 }
00419
00420
00421 pointer SAVE(ctx,n,argv)
00422 register context *ctx;
00423 int n;
00424 pointer argv[];
00425 { error(E_USER,(pointer)"SAVE is not supported on Solaris");}
00426
00427
00428 void loadsave(ctx,mod)
00429 register context *ctx;
00430 pointer mod;
00431 { pointer p=Spevalof(PACKAGE);
00432 pointer_update(Spevalof(PACKAGE),syspkg);
00433 defun(ctx,"SRCLOAD",mod,SRCLOAD);
00434 #if Solaris2 && !GCC
00435 defun(ctx,"LIST-MODULE-INITIALIZERS",mod,list_module_initializers);
00436 #else
00437 defun(ctx,"LIST-MODULE-INITIALIZERS",mod,list_module_initializers2);
00438 #endif
00439 defun(ctx,"FIND-ENTRY", mod, FIND_ENTRY);
00440 defun(ctx,"FIND-ENTRY2", mod, FIND_ENTRY2);
00441 defun(ctx,"SYSMOD", mod, SYSMOD);
00442 defun(ctx,"BINLOAD",mod,BINLOAD);
00443 defun(ctx,"UNBINLOAD",mod,UNBINLOAD);
00444 defun(ctx,"SAVE",mod,SAVE);
00445 pointer_update(Spevalof(PACKAGE),p);}
00446
00447