#ifndef lint
static char *rcsid =
   "$Header: lam7.c,v 1.8 84/04/06 23:09:07 layer Exp $";
#endif

/*					-[Fri Aug  5 12:51:31 1983 by jkf]-
 * 	lam7.c				$Locker:  $
 * lambda functions
 *
 * (c) copyright 1982, Regents of the University of California
 */

#include "global.h"
#include <signal.h>

char *sprintf();

lispval
Lfork() {
	int pid;

	chkarg(0,"fork");
	if ((pid=fork())) {
		return(inewint(pid));
	} else
		return(nil);
}

lispval
Lwait()
{
	register lispval ret, temp;
	int status = -1, pid;
	Savestack(2);


	chkarg(0,"wait");
	pid = wait(&status);
	ret = newdot();
	protect(ret);
	temp = inewint(pid);
	ret->d.car = temp;
	temp = inewint(status);
	ret->d.cdr = temp;
	Restorestack();
	return(ret);
}

lispval
Lpipe()
{
	register lispval ret, temp;
	int pipes[2];
	Savestack(2);

	chkarg(0,"pipe");
	pipes[0] = -1;
	pipes[1] = -1;
	pipe(pipes);
	ret = newdot();
	protect(ret);
	temp = inewint(pipes[0]);
	ret->d.car = temp;
	temp = inewint(pipes[1]);
	ret->d.cdr = temp;
	Restorestack();
	return(ret);
}

lispval
Lfdopen()
{
	register lispval fd, type;
	FILE *ptr;

	chkarg(2,"fdopen");
	type = (np-1)->val;
	fd = lbot->val;
	if( TYPE(fd)!=INT )
		return(nil);
	if ( (ptr=fdopen((int)fd->i, (char *)type->a.pname))==NULL)
		return(nil);
	return(P(ptr));
}

lispval
Lexece()
{
	lispval fname, arglist, envlist, temp;
	char *args[100], *envs[100], estrs[1024];
	char *p, *cp, **argsp;

	fname = nil;
	arglist = nil;
	envlist = nil;

	switch(np-lbot) {
	case 3: envlist = lbot[2].val;
	case 2: arglist = lbot[1].val;
	case 1: fname   = lbot[0].val;
	case 0: break;
	default:
		argerr("exece");
	}

	while (TYPE(fname)!=ATOM)
	   fname = error("exece: non atom function name",TRUE);
	while (TYPE(arglist)!=DTPR && arglist!=nil)
		arglist = error("exece: non list arglist",TRUE);
	for (argsp=args; arglist!=nil; arglist=arglist->d.cdr) {
		temp = arglist->d.car;
		if (TYPE(temp)!=ATOM)
			error("exece: non atom argument seen",FALSE);
		*argsp++ = temp->a.pname;
	}
	*argsp = 0;
	if (TYPE(envlist)!=DTPR && envlist!=nil)
		return(nil);
	for (argsp=envs,cp=estrs; envlist!=nil; envlist=envlist->d.cdr) {
		temp = envlist->d.car;
		if (TYPE(temp)!=DTPR || TYPE(temp->d.car)!=ATOM
		  || TYPE(temp->d.cdr)!=ATOM)
 		     error("exece: Bad enviroment list",FALSE);
		*argsp++ = cp;
		for (p=temp->d.car->a.pname; (*cp++ = *p++);) ;
		*(cp-1) = '=';
		for (p=temp->d.cdr->a.pname; (*cp++ = *p++);) ;
	}
	*argsp = 0;
	
	return(inewint(execve(fname->a.pname, args, envs)));
}

/* Lprocess -
 * C code to implement the *process function
 * call:
 * 	(*process 'st_command ['s_readp ['s_writep]])
 * where st_command is the command to execute
 *   s_readp is non nil if you want a port to read from returned
 *   s_writep is non nil if you want a port to write to returned
 *   both flags default to nil
 * *process returns
 *    the exit status of the process if s_readp and s_writep not given
 *	(in this case the parent waits for the child to finish)
 *    a list of (readport writeport childpid) if one of s_readp or s_writep
 *    is given.  If only s_readp is non nil, then writeport will be nil,
 *    If only s_writep is non nil, then readport will be nil
 */

lispval
Lprocess()
{
	int wflag , childsi , childso , child;
	lispval handy;
	char *command, *p;
	int writep, readp;
	int itemp;
	int (*handler)(), (*signal())();
	FILE *bufs[2],*obufs[2], *fpipe();
	Savestack(0);

	writep = readp = FALSE;
	wflag = TRUE;
	
	switch(np-lbot) {
	case 3:  if(lbot[2].val != nil) writep = TRUE;
	case 2:  if(lbot[1].val != nil) readp = TRUE;
		 wflag = 0;
	case 1:  command = (char *) verify(lbot[0].val,
			   	  	    "*process: non atom first arg");
		 break;
	default:
		argerr("*process");
	}
	
	childsi = 0;
	childso = 1;

	/* if there will be communication between the processes,
	 * it will be through these pipes:
	 *  parent ->  bufs[1] ->  bufs[0] -> child    if writep
	 *  parent <- obufs[0] <- obufs[1] <- parent   if readp
	 */
	if(writep) {
	    fpipe(bufs);
	    childsi = fileno(bufs[0]);
	}
	
	if(readp) {
		fpipe(obufs);
		childso = fileno(obufs[1]);
	}
	
	handler = signal(SIGINT,SIG_IGN);
	if((child = vfork()) == 0 ) {
	        /* if we will wait for the child to finish
		 * and if the process had ignored interrupts before
		 * we were called, then leave them ignored, else
		 * set it back the the default (death)
		 */
		if(wflag && handler != SIG_IGN)
			signal(2,SIG_DFL);
			
		if(writep) {
			close(0);
			dup(childsi);
		}
		if (readp) {
			close(1);
			dup(childso);
		}
		if ((p = (char *)getenv("SHELL")) != (char *)0) {
			execlp(p , p, "-c",command,0);
			_exit(-1); /* if exec fails, signal problems*/
		} else {
			execlp("csh", "csh", "-c",command,0);
			execlp("sh", "sh", "-c",command,0);
			_exit(-1); /* if exec fails, signal problems*/
		}
	}

	/* close the duplicated file descriptors
	 * e.g. if writep is true then we've created two desriptors,
	 *  bufs[0] and bufs[1],  we will write to bufs[1] and the
	 *  child (who has a copy of our bufs[0]) will read from bufs[0]
	 *  We (the parent) close bufs[0] since we will not be reading
	 *  from it.
	 */
	if(writep) fclose(bufs[0]);
	if(readp) fclose(obufs[1]);

	if(wflag && child!= -1) {
		int status=0;
		/* we await the death of the child */
		while(wait(&status)!=child) {}
		/* the child has died */
		signal(2,handler);	/* restore the interrupt handler */
		itemp = status >> 8;
		Restorestack();
		return(inewint(itemp));	/* return its status */
	}
	/* we are not waiting for the childs death
	 * build a list containing the write and read ports
	 */
	protect(handy = newdot());
	handy->d.cdr = newdot();
	handy->d.cdr->d.cdr = newdot();
	if(readp) {
	    handy->d.car = P(obufs[0]);
	    ioname[PN(obufs[0])] = (lispval) inewstr((char *) "from-process");
	}
	if(writep) {
	    handy->d.cdr->d.car = P(bufs[1]);
	    ioname[PN(bufs[1])] = (lispval) inewstr((char *) "to-process");
	}
	handy->d.cdr->d.cdr->d.car = (lispval) inewint(child);
	signal(SIGINT,handler);
	Restorestack();
	return(handy);
}

extern int gensymcounter;

lispval
Lgensym()
{
	lispval arg;
	char leader;

	switch(np-lbot)
	{
	    case 0: arg = nil;
		    break;
	    case 1: arg = lbot->val;
		    break;
	    default: argerr("gensym");
	}
	leader = 'g';
	if (arg != nil && TYPE(arg)==ATOM)
		leader = arg->a.pname[0];
	sprintf(strbuf, "%c%05d", leader, gensymcounter++);
	atmlen = 7;
	return((lispval)newatom(0));
}

extern struct types {
char	*next_free;
int	space_left,
	space,
	type,
	type_len;			/*  note type_len is in units of int */
lispval *items,
	*pages,
	*type_name;
struct heads
	*first;
} atom_str ;

lispval
Lremprop()
{
	register struct argent *argp;
	register lispval pptr, ind, opptr;
	lispval atm;
	int disemp = FALSE;

	chkarg(2,"remprop");
	argp = lbot;
	ind = argp[1].val;
	atm = argp->val;
	switch (TYPE(atm)) {
	case DTPR:
		pptr = atm->d.cdr;
		disemp = TRUE;
		break;
	case ATOM:
		if((lispval)atm==nil)
			pptr = nilplist;
		else
			pptr = atm->a.plist;
		break;
	default:
		errorh1(Vermisc, "remprop: Illegal first argument :",
		       nil, FALSE, 0, atm);
	}
	opptr = nil;
	if (pptr==nil) 
		return(nil);
	while(TRUE) {
		if (TYPE(pptr->d.cdr)!=DTPR)
			errorh1(Vermisc, "remprop: Bad property list",
			       nil, FALSE, 0,atm);
		if (pptr->d.car == ind) {
			if( opptr != nil)
				opptr->d.cdr = pptr->d.cdr->d.cdr;
			else if(disemp)
				atm->d.cdr = pptr->d.cdr->d.cdr;
			else if(atm==nil)
				nilplist = pptr->d.cdr->d.cdr;
			else
				atm->a.plist = pptr->d.cdr->d.cdr;
			return(pptr->d.cdr);
		}
		if ((pptr->d.cdr)->d.cdr == nil) return(nil);
		opptr = pptr->d.cdr;
		pptr = (pptr->d.cdr)->d.cdr;
	}
}

lispval
Lbcdad()
{
	lispval ret, temp;

	chkarg(1,"bcdad");
	temp = lbot->val;
	if (TYPE(temp)!=ATOM)
		error("ONLY ATOMS HAVE FUNCTION BINDINGS", FALSE);
	temp = temp->a.fnbnd;
	if (TYPE(temp)!=BCD)
		return(nil);
	ret = newint();
	ret->i = (int)temp;
	return(ret);
}

lispval
Lstringp()
{
	chkarg(1,"stringp");
	if (TYPE(lbot->val)==STRNG)
		return(tatom);
	return(nil);
}

lispval
Lsymbolp()
{
	chkarg(1,"symbolp");
	if (TYPE(lbot->val)==ATOM)
		return(tatom);
	return(nil);
}

lispval
Lrematom()
{
	register lispval temp;

	chkarg(1,"rematom");
	temp = lbot->val;
	if (TYPE(temp)!=ATOM)
		return(nil);
	temp->a.fnbnd = nil;
	temp->a.pname = (char *)CNIL;
	temp->a.plist = nil;
	(atom_items->i)--;
	(atom_str.space_left)++;
	temp->a.clb=(lispval)atom_str.next_free;
	atom_str.next_free=(char *) temp;
	return(tatom);
}

#define QUTMASK 0200
#define VNUM 0000

lispval
Lprname()
{
	lispval a, ret;
	register lispval work, prev;
	char	*front, *temp; int clean;
	char ctemp[100];
	extern unsigned char *ctable;
	Savestack(2);

	chkarg(1,"prname");
	a = lbot->val;
	switch (TYPE(a)) {
		case INT:
			sprintf(ctemp,"%d",a->i);
			break;

		case DOUB:
			sprintf(ctemp,"%f",a->r);
			break;
	
		case ATOM:
			temp = front = a->a.pname;
			clean = *temp;
			if (*temp == '-') temp++;
			clean = clean && (ctable[*temp] != VNUM);
			while (clean && *temp)
				clean = (!(ctable[*temp++] & QUTMASK));
			if (clean)
				strncpy(ctemp, front, 99);
			else	
				sprintf(ctemp,"\"%s\"",front);
			break;
	
		default:
			error("prname does not support this type", FALSE);
	}
	temp = ctemp;
	protect(ret = prev = newdot());
	while (*temp) {
		prev->d.cdr = work = newdot();
		strbuf[0] = *temp++;
		strbuf[1] = 0;
		work->d.car = getatom(FALSE);
		work->d.cdr = nil;
		prev = work;
	}
	Restorestack();
	return(ret->d.cdr);
}

lispval
Lexit()
{
	register lispval handy;
	if(np-lbot==0) franzexit(0);
	handy = lbot->val;
	if(TYPE(handy)==INT)
		franzexit((int) handy->i);
	franzexit(-1);
}
lispval
Iimplode(unintern)
{
	register lispval handy, work;
	register char *cp = strbuf;
	extern int atmlen;	/* used by newatom and getatom */
	extern char *atomtoolong();

	chkarg(1,"implode");
	for(handy = lbot->val; handy!=nil; handy = handy->d.cdr)
	{
		work = handy->d.car;
		if(cp >= endstrb)
			cp = atomtoolong(cp);
	again:
		switch(TYPE(work))
		{
		case ATOM:
			*cp++ = work->a.pname[0];
			break;
		case SDOT:
			*cp++ = work->s.I;
			break;
		case INT:
			*cp++ = work->i;
			break;
		case STRNG:
			*cp++ = * (char *) work;
			break;
		default:
			work = errorh1(Vermisc,"implode/maknam: Illegal type for this arg:",nil,FALSE,44,work);
			goto again;
		}
	}
	*cp = 0;
	if(unintern) return((lispval)newatom(FALSE));
	else return((lispval) getatom(FALSE));
}

lispval
Lmaknam()
{
	return(Iimplode(TRUE));		/* unintern result */
}

lispval
Limplode()
{
	return(Iimplode(FALSE));	/* intern result */
}

lispval
Lntern()
{
	register int hash;
	register lispval handy,atpr;


	chkarg(1,"intern");
	if(TYPE(handy=lbot->val) != ATOM)
		errorh1(Vermisc,"non atom to intern ",nil,FALSE,0,handy);
	/* compute hash of pname of arg */
	hash = hashfcn(handy->a.pname);

	/* search for atom with same pname on hash list */

	atpr = (lispval) hasht[hash];
	for(atpr = (lispval) hasht[hash] 
		 ; atpr != CNIL 
		 ; atpr = (lispval)atpr->a.hshlnk)
	{
		if(strcmp(atpr->a.pname,handy->a.pname) == 0) return(atpr);
	}
	
	/* not there yet, put the given one on */

	handy->a.hshlnk = hasht[hash];
	hasht[hash] = (struct atom *)handy;
	return(handy);
}

/*** Ibindvars :: lambda bind values to variables
	called with a list of variables and values.
	does the special binding and returns a fixnum which represents
	the value of bnp before the binding
	Use by compiled progv's.
 ***/
lispval
Ibindvars()
{
    register lispval vars,vals,handy;
    struct nament *oldbnp = bnp;

    chkarg(2,"int:bindvars");

    vars = lbot[0].val;
    vals = lbot[1].val;

    if(vars == nil) return(inewint(oldbnp));

    if(TYPE(vars) != DTPR)
      errorh1(Vermisc,"progv (int:bindvars): bad first argument ", nil,
      		FALSE,0,vars);
   if((vals != nil) && (TYPE(vals) != DTPR))
     errorh1(Vermisc,"progv (int:bindvars): bad second argument ",nil,
     		FALSE,0,vals);

   for( ; vars != nil ; vars = vars->d.cdr , vals=vals->d.cdr)
   {
       handy = vars->d.car;
       if(TYPE(handy) != ATOM)
          errorh1(Vermisc,"progv (int:bindvars): non symbol argument to bind ",
	  	nil,FALSE,0,handy);
       PUSHDOWN(handy,vals->d.car);
   }
   return(inewint(oldbnp));
}


/*** Iunbindvars :: unbind the variable stacked by Ibindvars
     called by compiled progv's
 ***/
 
lispval
Iunbindvars()
{
    struct nament *oldbnp;
    
    chkarg(1,"int:unbindvars");
    oldbnp = (struct nament *) (lbot[0].val->i);
    if((oldbnp < orgbnp)  || ( oldbnp > bnp))
       errorh1(Vermisc,"int:unbindvars: bad bnp value given ",nil,FALSE,0,
       		lbot[0].val);
    popnames(oldbnp);
    return(nil);
}

/*
 * (time-string ['x_milliseconds])
 * if given no argument, returns the current time as a string
 * if given an argument which is a fixnum representing the current time
 * as a fixnum, it generates a string from that
 *
 * the format of the string returned is that defined in the Unix manual
 * except the trailing newline is removed.
 *
 */
lispval
Ltymestr()
{
    long timevalue;
    char *retval;
    
    switch(np-lbot)
    {
	case 0: time(&timevalue);
		break;
	case 1: while (TYPE(lbot[0].val) != INT)
	          lbot[0].val =
		     errorh(Vermisc,"time-string: non fixnum argument ",
		     		nil,TRUE,0,lbot[0].val);
		timevalue = lbot[0].val->i;
		break;
	default:
		argerr("time-string");
    }

    retval = (char *) ctime(&timevalue);
    /* remove newline character */
    retval[strlen(retval)-1] = '\0';
    return((lispval) inewstr(retval));
}