예제 #1
0
lispval
cmpx(lssp)
{
	register struct argent *argp;
	register struct argent *outarg;
	register struct argent *onp = np;
	Savestack(3);


	argp = lbot + 1;
	outarg = np;
	while(argp < onp) {

		np = outarg + 2;
		lbot = outarg;
		if(lssp)
			*outarg = argp[-1], outarg[1]  = *argp++;
		else
			outarg[1]  = argp[-1], *outarg = *argp++;
		lbot->val = Lsub();
		np = lbot + 1;
		if(Lnegp()==nil) 
		{
		    Restorestack();
		    return(nil);
		}
	}
	Restorestack();
	return(tatom);
}
예제 #2
0
파일: fex1.c 프로젝트: Yizong98/franz-lisp
/*
   Ncatch is now linked to the lisp symbol *catch , which has the form
     (*catch tag form)
    tag is evaluated and then the catch entry is set up.
      then form is evaluated
    finally the catch entry is removed.

  *catch is still an nlambda since its arguments should not be evaluated
   before this routine is called.

   (catch form [tag]) is translated to (*catch 'tag form) by a macro.
 */
lispval
Ncatch()
{
	register lispval tag;
	pbuf pb;
	Savestack(3);		/* save stack pointers */

	if((TYPE(lbot->val))!=DTPR) return(nil);
	protect(tag = eval(lbot->val->d.car));  /* protect tag from gc */

	errp = Pushframe(F_CATCH,tag,nil);

	switch(retval) {

	case C_THROW: 	/*
		       	 * value thrown is in lispretval
		       	 */
			break;

	case C_INITIAL: /*
			 * calculate value of expression
			 */
			 lispretval = eval(lbot->val->d.cdr->d.car);
	}
			
			
	errp = Popframe();
	Restorestack();
	return(lispretval);
}
예제 #3
0
lispval
Lflatsi()
{
	register lispval current;
	Savestack(1); 			/* fixup entry mask */

	fmax = 0x7fffffff;	/* biggest integer by default */
	switch(np-lbot) 
	{
	    case 2: current = lbot[1].val;
		    while(TYPE(current) != INT)
			current = errorh1(Vermisc,
					"flatsize: second arg not integer",
					nil,TRUE,0,current);
		    fmax = current->i;
	    case 1: break;
	    default: argerr("flatsize");
	}

	flen = 0; 
	current = lbot->val;
	protect(nil); 			/*create space for argument to pntlen*/
	Iflatsi(current);
	Restorestack();
	return(inewint(flen));
}
예제 #4
0
lispval
Lsub1()
{
	register lispval handy;
	lispval Ladd();
	Savestack(1); /* fixup entry mask */
	chkarg(1,"sub1");
	
	if((TYPE(lbot->val) == INT) && (lbot->val->i > MinINT))
	{
	    Restorestack();
	    return(inewint(lbot->val->i - 1));
	}

	handy = rdrint;
	handy->i = - 1;
	protect(handy);
	handy=Ladd();
	Restorestack();
	return(handy);
}
예제 #5
0
lispval
Ladd1()
{
	register lispval handy;
	lispval Ladd();
	Savestack(1); /* fixup entry mask */
	chkarg(1,"add1");

	/* simple test first */
	if((TYPE(lbot->val) == INT) && (lbot->val->i < MaxINT))
	{
	    Restorestack();
	    return(inewint(lbot->val->i + 1));
	}
	
	handy = rdrint;
	handy->i = 1;
	protect(handy);
	handy=Ladd();
	Restorestack();
	return(handy);

}
예제 #6
0
파일: trace.c 프로젝트: Yizong98/franz-lisp
lispval
Lfunhook()
{
    register lispval handy;
    register lispval evalhval = CNIL;
    Savestack(2);


    switch (np-lbot) 
    {
    case 2: break;
    case 3: evalhval = (lbot+2)->val;
	    break;
    default: argerr("funcallhook");
    }

    /* Don't do this check any longer
     * if (evalhsw == 0) 
     *	    error("funcallhook called before doing sstatus-evalhook", TRUE);
     *if (rsetsw == 0 || rsetatom->a.clb == nil)
     *	    error("funcallhook called while not in *rset mode", TRUE);
     */
     
    handy = lbot->val;
    while (TYPE(handy) != DTPR) 
      handy = errorh1(Vermisc,"funcallhook: first arg must be a list",nil,TRUE,
					   0,handy);
    if(evalhval != CNIL) { PUSHDOWN(evalhatom,evalhval); }

    PUSHDOWN(funhatom,(lispval)(lbot+1)->val);
    /* funcall checks funcallhcall to see if this is a LISP call to evalhook
	in which case it avoids call to evalhook function, but clobbers
	value to nil so recursive calls will check.  */
    funhcallsw = TRUE;	
    /*
     * the first argument to funhook is a list of already evaluated expressions
     * which we just stack can call funcall on
     */
    lbot = np;		/* base of new args */
    for ( ; handy != nil ; handy = handy->d.cdr)
    {
	protect(handy->d.car);
    }
    handy = Lfuncal();
    POP;
    if(evalhval != CNIL) { POP;  }
    Restorestack();
    return(handy);
}
예제 #7
0
파일: fex3.c 프로젝트: Yizong98/franz-lisp
lispval
Lgetaddress(){
	register struct argent *mlbot = lbot;
	register lispval work;
	register int numberofargs, i;
	char ostabf[128];
	struct nlist NTABLE[100];
	lispval dispget();

	Savestack(4);

	if(np-lbot == 2) protect(nil);	/* allow 2 args */
	numberofargs = (np - lbot)/3;
	if(numberofargs * 3 != np-lbot)
	   error("getaddress: arguments must come in triples ",FALSE);

	for ( i=0; i<numberofargs; i++,mlbot += 3) {
		NTABLE[i].n_value = 0;
	        mlbot[0].val = verify(mlbot[0].val,"Incorrect entry specification for binding");
		STASSGN(i,(char *) mlbot[0].val);
		while(TYPE(mlbot[1].val) != ATOM)
			mlbot[1].val = errorh1(Vermisc,
					"Bad associated atom name for binding",
					  nil,TRUE,0,mlbot[1].val);
		mlbot[2].val = dispget(mlbot[2].val,"getaddress: Incorrect discipline specification ",(lispval)Vsubrou->a.pname);
	}
		STASSGN(numberofargs,"");
	strncpy(ostabf,gstab(),128);
	if ( nlist(ostabf,NTABLE) == -1 ) {
	    errorh1(Vermisc,"Getaddress: Bad file",nil,FALSE,0,inewstr(ostabf));
	} else 
	    for (i=0,mlbot=lbot+1; i<numberofargs; i++,mlbot+=3) {
		if ( NTABLE[i].n_value == 0 )
		    fprintf(stderr,"Undefined symbol: %s\n",
			      NTABLE[i].N_name);
		else {
		    work= newfunct();
		    work->bcd.start = (lispval (*) ())NTABLE[i].n_value;
		    work->bcd.discipline = mlbot[1].val;
		    mlbot->val->a.fnbnd = work;
		}
	    };
	Restorestack();
	return(lbot[1].val->a.fnbnd);
};
예제 #8
0
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);
}
예제 #9
0
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);
}
예제 #10
0
파일: fex1.c 프로젝트: Yizong98/franz-lisp
lispval Nerrset()
{
	lispval temp,flag;
	pbuf pb;
	Savestack(0);

	if(TYPE(lbot->val) != DTPR) return(nil);	/* no form */

	/* evaluate and save flag first */
	flag = lbot->val->d.cdr;
	if(TYPE(flag) == DTPR) flag = eval(flag->d.car); 
	else flag = tatom; 	/* if not present , assume t */
	protect(flag);

	errp = Pushframe(F_CATCH,Verall,flag);

	switch(retval) {

	case C_THROW: 	/*
			 * error thrown to this routine, value thrown is
			 * in lispretval
			 */
			break;

	case C_INITIAL:	/*
			 * normally just evaluate expression and listify it.
			 */
			temp = eval(lbot->val->d.car);
			protect(temp);
			(lispretval = newdot())->d.car = temp;
			break;
	}

	errp = Popframe();
	Restorestack();
	return(lispretval);
}
예제 #11
0
/*
 *
 * (oblist)
 *
 * oblist returns a list of all symbols in the oblist
 *
 * written by jkf.
 */
lispval
Loblist()
{
    int indx;
    lispval headp, tailp ;
    struct atom *symb ;
    extern int hashtop;
    Savestack(0);

    headp = tailp = newdot(); /* allocate first DTPR */
    protect(headp);		/*protect the list from garbage collection*/
				/*line added by kls			  */

    for( indx=0 ; indx <= hashtop-1 ; indx++ ) /* though oblist */
    {
	for( symb = hasht[indx] ;
	     symb != (struct atom *) CNIL ;
	     symb = symb-> hshlnk)
	{
	    if(TYPE(symb) != ATOM) 
	    {   printf(" non symbol in hasht[%d] = %x: ",indx,symb);
		printr((lispval) symb,stdout);
		printf(" \n");
		fflush(stdout);
	    }
	    tailp->d.car = (lispval) symb  ; /* remember this atom */
	    tailp = tailp->d.cdr = newdot() ; /* link to next DTPR */
	}
    }

    tailp->d.cdr = nil ; /* close the list unfortunately throwing away
			  the last DTPR
			  */
    Restorestack();
    return(headp);
}
예제 #12
0
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 */
	}