/****************************************************************/
/* loadsave.sol.c
/*	load an euslisp source code file
/*	load a binary object file
/*	save current running image to a file
/*
/*	(c) T.Matsui, 1986
/****************************************************************/
static char *rcsid="@(#)$Id$";

#include <signal.h>
#include <ctype.h>
#include <sys/file.h>
#include <fcntl.h>
#include <dlfcn.h>
#if i86pc
#include <link.h>
#endif

#if alpha
#undef MAX
#undef MIN
#undef VMAX
#undef VMIN
#endif
#include "../c/eus.h"

extern int errno;
extern pointer openfile();
extern pointer makemodule(context *, int);

/****************************************************************/
/* load eus source
/*	Caution!!!
/*	This function does not ensure closing the input file,
/*	if an error occurs during load.
/*	So, this function should be used only for bootstrapping.
/*	Safer loader using with-open-file is defined in loader.l.
/****************************************************************/

pointer SRCLOAD(ctx,n,argv)
register context *ctx;
int n;
pointer argv[];
{ pointer in,form;
  ckarg(1);
  in=openfile(ctx,(char *)argv[0]->c.str.chars,O_RDONLY,0,256);
  vpush(in);
  if (in==0) error(E_OPENFILE);
  form=reader(ctx,in,NIL);
  while (form!=(pointer)EOF){
    /* prinx(ctx,form,ERROUT); flushstream(ERROUT); terpri(ERROUT);*/
    /*fprintf(stderr, "%x\n", form);*/
    eval(ctx,form);
    form=reader(ctx,in,NIL);
    }
  closestream(in);
  vpop();
  return(NIL);}

/****************************************************************/
/* binload
/*	dynamic shared object loader for EusLisp on Solaris
/*	1986-Jun-22
/*	1986-Oct-15	modified to accept compiled code
/*	May/17/1994	reimplemetation using 'dl'
/****************************************************************
/* object module loader for Solaris 2.3
/* (system:binload
/*	"object.o" "quote.q" "_entry")
/*	1987-April	for sun3
/*	1987-December	for vax ultrix
/*	1988-Nov	nothing special for sony news
/*	1993-Jan	Solaris 2.0 Elf... failed
/*	1994-May	Solaris 2.3 dynamic linker (dl)
/****************************************************************/

#define MAX_SYSTEM_MODULES 100
int module_count=0;
struct {
    pointer (*entry_func)();
    char *module_name;}
  module_initializers[MAX_SYSTEM_MODULES];


void add_module_initializer(name, entry)
char *name;
pointer (*entry)();
{ 
  /* printf("%s %x is added in the module_initializer list\n", name, entry); */
  if (module_count>=MAX_SYSTEM_MODULES)  error(E_USER,(pointer)"too many system modules");
  module_initializers[module_count].module_name= name;
  module_initializers[module_count].entry_func=  entry;
  module_count++;}

/* exec_module_initializers is no longer called */
void exec_module_initializers(ctx)
register context *ctx;
{ eusinteger_t i, addr;
  pointer (*initfunc)(context *, int, pointer *);
  pointer mod;
  for (i=0; i< module_count; i++) {
    printf("executing init: %s at %p...",
	 module_initializers[i].module_name,
	 module_initializers[i].entry_func);
    fflush(stdout);
    initfunc=module_initializers[i].entry_func;
    mod=makemodule(ctx,0);
    vpush(mod);
    breakck;
    if (initfunc) { 
      addr = (eusinteger_t)initfunc;
      addr= addr>>2;
      mod->c.ldmod.entry=makeint(addr);
#if ARM
      mod->c.ldmod.entry2=makeint((eusinteger_t)initfunc);
#endif
      mod->c.ldmod.subrtype=SUBR_ENTRY;
      (*initfunc)(ctx,1, &mod); }
    vpop();
    printf(" ok\n");}
  module_count=0;}

#if Solaris2 && !GCC
pointer list_module_initializers(ctx,initnames)
context *ctx;
pointer initnames;
{ int i, addr;
  pointer (*initfunc)(int, pointer *);
  pointer mod, modname, p;
  for (i=0; i<module_count; i++) {
    initfunc=module_initializers[i].entry_func;
    modname=makestring(module_initializers[i].module_name,
			strlen(module_initializers[i].module_name));
    vpush(modname);
    addr= (int)initfunc; addr >>=2;
    mod=makemodule(ctx,0);
    mod->c.ldmod.codevec=makeint(0);
    mod->c.ldmod.entry=makeint(addr);
    mod->c.ldmod.subrtype=SUBR_FUNCTION;
    if (debug)  
      printf("collecting init: %s at %x module at %x\n",
	 module_initializers[i].module_name,
	 module_initializers[i].entry_func, mod);
    p=cons(ctx,mod, NIL);
    p=cons(ctx,vpop(), p);	/* (list modname mod) */
    vpush(p);}
  p=(pointer)stacknlist(ctx,module_count);
  module_count=0;
  return(p);}

#else
pointer list_module_initializers(ctx, initnames)
context *ctx;
pointer initnames;
{ int i;
  eusinteger_t addr;
  pointer (*initfunc)(int, pointer *);
  pointer mod, modname, p;
  void *dlhandle;
  char namebuf[256];

  dlhandle=dlopen(0,RTLD_LAZY|RTLD_GLOBAL);
  if (dlhandle==NULL) { 
    fprintf(stderr, "cannot dlopen self\n"); exit(2);}
  module_count=0;
  while (iscons(initnames)) {
    /* printf("%s ", ccar(initnames)->c.str.chars); */
    initfunc= dlsym(dlhandle, (char *)ccar(initnames)->c.str.chars);
    if (initfunc==NULL) {
      sprintf(namebuf,"___%s",ccar(initnames)->c.str.chars);
      initfunc=dlsym(dlhandle, namebuf);}

    if (initfunc) {
      /* printf(" ok\n"); */
      modname=ccar(initnames);
      vpush(modname);
      addr= (eusinteger_t)initfunc; addr >>=2;/* ???? */
      mod=makemodule(ctx,0);
      mod->c.ldmod.codevec=makeint(0);
      mod->c.ldmod.entry=makeint(addr);
#if ARM
      mod->c.ldmod.entry2=makeint((eusinteger_t)initfunc);
#endif
      mod->c.ldmod.subrtype=SUBR_FUNCTION;
      p=cons(ctx,mod, NIL);
      p=cons(ctx,vpop(), p);	/* (list modname mod) */
      vpush(p); module_count++;
    }
/*    else {
     printf("%s not loaded\n", ccar(initnames)->c.str.chars);}*/
    initnames=ccdr(initnames); }
  p=(pointer)stacknlist(ctx,module_count);
  module_count=0;
  return(p);}

pointer list_module_initializers2(ctx, n, argv)
register context *ctx;
int n;
pointer *argv;
{ int i;
  eusinteger_t addr;
  pointer (*initfunc)(int, pointer *);
  pointer mod, modname, initnames, p;
  void *dlhandle;
  char namebuf[256];

  ckarg(2);
  if (!isldmod(argv[0])) error(E_USER,(pointer)"not a LOAD-MODULE");
  if (!iscons(argv[1])) error(E_NOLIST);
#if (WORD_SIZE == 64)
  dlhandle=(void *)((eusinteger_t)(argv[0]->c.ldmod.handle) & ~3L);
#else
  dlhandle=(void *)((eusinteger_t)(argv[0]->c.ldmod.handle) & ~3);
#endif
  initnames=argv[1];
  module_count=0;
  if (dlhandle==NULL) error(E_USER,(pointer)"This module was not loaded");

  while (iscons(initnames)) {
    initfunc= dlsym(dlhandle, (char *)ccar(initnames)->c.str.chars);
    if (initfunc==NULL) {
      sprintf(namebuf,"___%s",ccar(initnames)->c.str.chars);
      initfunc=dlsym(dlhandle, namebuf);}

    if (initfunc) {
      modname=ccar(initnames);
      vpush(modname);
      addr= (eusinteger_t)initfunc; addr >>=2;/* ???? */
      mod=makemodule(ctx,0);
      mod->c.ldmod.codevec=makeint(0);
      mod->c.ldmod.entry=makeint(addr);
#if ARM
      mod->c.ldmod.entry2=makeint((eusinteger_t)initfunc);
#endif
      mod->c.ldmod.subrtype=SUBR_FUNCTION;
      p=cons(ctx,mod, NIL);
      p=cons(ctx,vpop(), p);	/* (list modname mod) */
      vpush(p); module_count++;}
    else {
     printf("%s not loaded\n", ccar(initnames)->c.str.chars); }
    initnames=ccdr(initnames); }
  p=(pointer)stacknlist(ctx,module_count);
  module_count=0;
  return(p);}
#endif

pointer build_quote_vector(ctx,size, strings)
register context *ctx;
int size;
char *strings[];
{ pointer qvec, p, qstring, qstream;
  int i, k;
  qvec=makevector(C_VECTOR,size);
  vpush(qvec);
  qstream=(pointer)mkstream(ctx,K_IN,makestring("",0));
  vpush(qstream);
  for (i=0; i<size; i++) {
    k=strlen((char *)strings[i]);
    qstring=makestring(strings[i], k);
    /*prinx(ctx,qstring, STDOUT); terpri(STDOUT); */
    pointer_update(qstream->c.stream.buffer,qstring);
    qstream->c.stream.count=makeint(0);
    qstream->c.stream.tail=makeint(k);
    pointer_update(qvec->c.vec.v[i],reader(ctx,qstream, NIL));}
  vpop();
  vpop();
  /* prinx(ctx,qvec, STDOUT); */
#ifdef SAFETY
  take_care(qvec);
#endif
  return(qvec);}

pointer eval_c_strings(ctx,size, strings)
register context *ctx;
int size;
const char *strings[];
{ pointer p, qstream, qstring;
  int i, k, total_length;
  char *s;
  byte *d;

  total_length=size;
  for (i=0; i<size; i++) { total_length += strlen(strings[i]); }
  qstring = makebuffer(total_length);
  vpush(qstring);
  d=qstring->c.str.chars;
  for (i=0; i<size; i++) {
    s=(char *)strings[i];
    while (*s) *d++ = *s++;
    *d++= '\n';}	/* newline is needed to ensure the reader
			   to stop ignoring comments */
  qstream=(pointer)mkstream(ctx,K_IN, qstring);
  vpush(qstream);
  qstream->c.stream.tail=makeint(total_length);
  while ((p=reader(ctx,qstream, NIL))!= (pointer)(-1))  {
     if (debug) { prinx(ctx,p,STDOUT); terpri(STDOUT);  }
     p=eval(ctx,p);}
  vpop();
  vpop();
  return(p);}

pointer FIND_ENTRY(ctx,n,argv)
register context *ctx;
int n;
pointer argv[];
{ pointer entry, mod;
  char *entry_string;
  extern pointer sysmod;

  ckarg2(1,2);
  if (n==2) mod=argv[1];
  else mod=sysmod;
  if (!isldmod(mod)) error(E_USER,(pointer)"not a LOAD-MODULE");
  entry_string=(char *)get_string(argv[0]);
#if (WORD_SIZE == 64)
  entry=(pointer)dlsym((void *)((eusinteger_t)(mod->c.ldmod.handle) & ~3L), entry_string);
#else
  entry=(pointer)dlsym((void *)((eusinteger_t)(mod->c.ldmod.handle) & ~3), entry_string);
#endif
  if (entry==NULL) return(NIL);
  else return(makeint((eusinteger_t)entry>>2));}

pointer FIND_ENTRY2(ctx,n,argv)
register context *ctx;
int n;
pointer argv[];
{ pointer entry, mod, e=NIL;
  char *entry_string;
  extern pointer sysmod;

  ckarg2(1,2);
  if (n==2) mod=argv[1];
  else mod=sysmod;
  if (!isldmod(mod)) error(E_USER,(pointer)"not a LOAD-MODULE");
  entry_string=(char *)get_string(argv[0]);
#if (WORD_SIZE == 64)
  entry=(pointer)dlsym((void *)((eusinteger_t)(mod->c.ldmod.handle) & ~3L), entry_string);
#else
  entry=(pointer)dlsym((void *)((eusinteger_t)(mod->c.ldmod.handle) & ~3), entry_string);
#endif
  if (entry==NULL) return(NIL);
  else {
    e=cons(ctx,makeint((eusinteger_t)entry),e);
    e=cons(ctx,makeint((eusinteger_t)entry>>2),e);
    return(e);}}

extern pointer sysmod;

pointer SYSMOD()
{ return(sysmod);}

pointer UNBINLOAD(ctx,n,argv)
register context *ctx;
int n;
pointer *argv;
{ register pointer mod=argv[0];
  register int stat;
  ckarg(1);
  if (!isldmod(mod)) error(E_USER,(pointer)"not a compiled-module");
#if (WORD_SIZE == 64)
  stat=dlclose((void *)((eusinteger_t)(mod->c.ldmod.handle) & ~3L));
#else
  stat=dlclose((void *)((eusinteger_t)(mod->c.ldmod.handle) & ~3));
#endif
  if (stat) return(makeint(-errno));
  else return(T);}

pointer BINLOAD(ctx,n,argv)
register context *ctx;
int n;
pointer *argv;
{ char *binfn, *quofn;	/*binary and quote file names*/
  char *entry;
  int binfd,size,newsize,stat,i=0,l,s;
  pointer mod,quostrm,qvec;
  byte *loadaddress;
  pointer (*initfunc)(context *, int, pointer *);
  int data_align=0;
  eusinteger_t dlhandle, addr;

  ckarg2(1,2);
  binfn= (char *)get_string(argv[0]);
  if (n==2) {
    if (argv[1]==NIL) entry=NULL;
    else entry=(char *)get_string(argv[1]);}
  else entry=NULL;

  dlhandle=(eusinteger_t)dlopen(binfn, RTLD_LAZY|RTLD_GLOBAL);/* ???? */
  if (dlhandle == 0) {
    fprintf(stderr,"BINLOAD cannot dlopen: %s\n", dlerror());
    return(NIL);}
  initfunc=NULL;
  if (entry) {
    initfunc=(pointer (*)(context *, int, pointer *))dlsym((void *)dlhandle, entry);
    if (initfunc==NULL)
      initfunc=(pointer (*)(context *, int, pointer *))dlsym((void *)dlhandle, &entry[3]);
/*    if (initfunc==NULL) fprintf(stderr, ";; entry not found\n");*/
  }
  mod=makemodule(ctx,0);
  pointer_update(mod->c.ldmod.objname,argv[0]);
  mod->c.ldmod.handle=makeint(dlhandle>>2);
  vpush(mod);

  /*call initializer*/
  breakck;
  if (initfunc) { 
    addr=(eusinteger_t)initfunc; addr >>=2;/* ???? */
    mod->c.ldmod.codevec=makeint(0);
    mod->c.ldmod.entry=makeint(addr);
#if ARM
    mod->c.ldmod.entry2=makeint((eusinteger_t)initfunc);
#endif
    mod->c.ldmod.subrtype=SUBR_FUNCTION;
    (*initfunc)(ctx, 1, &mod); }
  else if (debug) fprintf(stderr,";; no initializer\n");
  return(vpop());	/* return the module */
  }


pointer SAVE(ctx,n,argv)
register context *ctx;
int n;
pointer argv[];
{ error(E_USER,(pointer)"SAVE is not supported on Solaris");}


void loadsave(ctx,mod)
register context *ctx;
pointer mod;
{ pointer p=Spevalof(PACKAGE);
  pointer_update(Spevalof(PACKAGE),syspkg);
  defun(ctx,"SRCLOAD",mod,SRCLOAD,NULL);
#if Solaris2 && !GCC
  defun(ctx,"LIST-MODULE-INITIALIZERS",mod,list_module_initializers,NULL);
#else
  defun(ctx,"LIST-MODULE-INITIALIZERS",mod,list_module_initializers2,NULL);
#endif
  defun(ctx,"FIND-ENTRY", mod, FIND_ENTRY,NULL);
  defun(ctx,"FIND-ENTRY2", mod, FIND_ENTRY2,NULL);
  defun(ctx,"SYSMOD", mod, SYSMOD,NULL);
  defun(ctx,"BINLOAD",mod,BINLOAD,NULL);
  defun(ctx,"UNBINLOAD",mod,UNBINLOAD,NULL);
  defun(ctx,"SAVE",mod,SAVE,NULL);
  pointer_update(Spevalof(PACKAGE),p);}