Ejemplo n.º 1
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));
}
Ejemplo n.º 2
0
lispval
Lnegp()
{
	register lispval handy = np[-1].val, work;
	register flag = 0;

loop:
	switch(TYPE(handy)) {
	case INT:
		if(handy->i < 0) flag = TRUE;
		break;
	case DOUB:
		if(handy->r < 0) flag = TRUE;
		break;
	case SDOT:
		for(work = handy;
		    work->s.CDR!=(lispval) 0;
		    work = work->s.CDR) {;}
		if(work->s.I < 0) flag = TRUE;
		break;
	default:
		handy = errorh1(Vermisc,
				  "minusp: Non-(int,real,bignum) arg: ",
				  nil,
				  TRUE,
				  0,
				  handy);
		goto loop;
	}
	if(flag) return(tatom);
	return(nil);
}
Ejemplo n.º 3
0
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);
};
Ejemplo n.º 4
0
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);
}
Ejemplo n.º 5
0
/* to one.								*/
lispval
Ngo() 
{
    register lispval temp;
    chkarg(1,"go");

    temp = (lbot->val)->d.car;
    if (TYPE(temp) != ATOM)
    {
	temp = eval(temp);
	while(TYPE(temp) != ATOM) 
	  temp = errorh1(Vermisc,"Illegal tag to go to",nil,TRUE, 0,lbot->val);
    }
    Inonlocalgo(C_GO,temp,nil);
    /* NOT REACHED */
}
Ejemplo n.º 6
0
lispval
Lxcdr()
{   register int typ;
    register lispval temp;

    chkarg(1,"xcdr");
    temp = lbot->val;
    if(temp==nil) return (nil);

    if (((typ = TYPE(temp)) == DTPR) || HUNKP(temp))
        return(temp->d.cdr);
    else if(typ==SDOT) {
        if(temp->s.CDR==0) return(nil);
        temp = temp->s.CDR;
        if(TYPE(temp)==DTPR)
            errorh1(Vermisc,"Fell off the end of a bignum",nil,FALSE,5,lbot->val);
        return(temp);
    } else if(Schainp!=nil && typ==ATOM)
        return(nil);
    else
        return(error("Bad arg to cdr", FALSE));
}
Ejemplo n.º 7
0
lispval
Nsetq()
{	register lispval handy, where, value;
	register int lefttype;

	value = nil;
	
	for(where = lbot->val; where != nil; where = handy->d.cdr) {
		handy = where->d.cdr;
		if((TYPE(handy))!=DTPR)
			error("odd number of args to setq",FALSE);
		if((lefttype=TYPE(where->d.car))==ATOM) {
			if(where->d.car==nil)
				error("Attempt to set nil",FALSE);
			where->d.car->a.clb = value = eval(handy->d.car);
		 }else if(lefttype==VALUE)
			where->d.car->l = value = eval(handy->d.car);
		else errorh1(Vermisc,
			    "Can only setq atoms or values",nil,FALSE,0,
			    		where->d.car);
	}
	return(value);
}
Ejemplo n.º 8
0
lispval
Nprog() {
	register lispval where, temp;
	struct nament *savedbnp = bnp;
	extern struct frame *errp;
	pbuf pb;
	extern int retval;
	extern lispval lispretval;

	if((np-lbot) < 1) chkarg(1,"prog");

	/* shallow bind the local variables to nil */
	if(lbot->val->d.car != nil)
	{
	    for( where = lbot->val->d.car ; where != nil; where = where->d.cdr )
	    {
	        if(TYPE(where) != DTPR || TYPE(temp=where->d.car) != ATOM)
		    errorh1(Vermisc,
			   "Illegal local variable list in prog ",nil,FALSE,
			   1,where);
    	        PUSHDOWN(temp,nil);
	    }
	}

	/* put a frame on the stack which can be 'return'ed to or 'go'ed to */
	errp = Pushframe(F_PROG,nil,nil);

	where = lbot->val->d.cdr;	/* first thing in the prog body */

	switch (retval)	{
	case C_RET:	/*
			 * returning from this prog, value to return
			 * is in lispretval
			 */
			errp = Popframe();
			popnames(savedbnp);
			return(lispretval);

	case C_GO:	/*
			 * going to a certain label, label to go to in
			 * in lispretval
			 */
			where = (lbot->val)->d.cdr;
			while ((TYPE(where) == DTPR) 
			       && (where->d.car != lispretval))
				where = where->d.cdr;
			if (where->d.car == lispretval) {
				popnames(errp->svbnp);
				break;
			}
			/* label not found in this prog, must 
			 * go up to higher prog
			 */
			errp = Popframe();	/* go to next frame */
			Inonlocalgo(C_GO,lispretval,nil);

			/* NOT REACHED */

	case C_INITIAL: break;

	}

	while (TYPE(where) == DTPR)
		{
		temp = where->d.car;
		if((TYPE(temp))!=ATOM) eval(temp);
		where = where->d.cdr;
		}
	if((where != nil) && (TYPE(where) != DTPR)) 
	    errorh1(Vermisc,"Illegal form in prog body ", nil,FALSE,0,where);
	errp = Popframe();
	popnames(savedbnp);	/* pop off locals */
	return(nil);
}
Ejemplo n.º 9
0
lispval
Lsetsyn()
{
	register lispval s, c;
	register struct argent *mynp;
	register index;
	lispval x   /*  ,debugmode  */;
	extern unsigned char *ctable;
	extern lispval Istsrch();

	switch(np-lbot) {
	case 2:
		x= nil;			/* only 2 args given */
	case 3:
		x = lbot[2].val;	/* all three args given */
		break;
	default:
		argerr("setsyntax");
	}
	s = Vreadtable->a.clb;
	chkrtab(s);
	/* debugging code 
	debugmode = Istsrch(matom("debugging"))->d.cdr->d.cdr->d.cdr;
	if(debugmode)  printf("Readtable addr: %x\n",ctable);
	  end debugging code */
	mynp = lbot;
	c = (mynp++)->val;
	s = (mynp++)->val;

	switch(TYPE(c)) {
	default:
		error("neither fixnum, atom or string as char to setsyntax",FALSE);

	case ATOM:
		index = *(c->a.pname);
		if((c->a.pname)[1])
		    errorh1(Vermisc,"Only 1 char atoms to setsyntax",
		         nil,FALSE,0,c);
		break;

	case INT:
		index = c->i;
		break;

	case STRNG:
		index = (int) *((char *) c);
	}
	switch(TYPE(s)) {
	case ATOM:
		if(s==splice || s==macro) {
		    if(s==splice)
			    ctable[index] = VSPL;
		    else if(s==macro)
			    ctable[index] = VMAC;
		    if(TYPE(c)!=ATOM) {
			    strbuf[0] = index;
			    strbuf[1] = 0;
			    c = (getatom(TRUE));
		    }
		    Iputprop(c,x,lastrtab);
		    return(tatom);
		}

		/* ... fall into */
	default:  errorh1(Vermisc,"int:setsyntax : illegal second argument ",
				nil,FALSE,0,s);
		/* not reached */
		
	case INT:
		switch(synclass(s->i)) {
		case CESC: Xesc = (char) index; break;
		case CDQ: Xdqc = (char) index; break;
		case CSD: Xsdc = (char) index;	/* string */
		}

		if(synclass(ctable[index])==CESC   /* if we changed the current esc */
		  && (synclass(s->i)!=CESC)          /* to something else, pick current */
		  && Xesc == (char) index) {
	       		ctable[index] = s->i;
			rpltab(CESC,&Xesc);
		}
		else if(synclass(ctable[index])==CDQ   /*  likewise for double quote */
		       && synclass(s->i) != CDQ
		       && Xdqc == (char) index)  {
			ctable[index] = s->i;
			rpltab(CDQ,&Xdqc);
		}
		else if(synclass(ctable[index]) == CSD  /* and for string delimiter */
			&& synclass(s->i) != CSD
			&& Xsdc == (char) index) {
			 ctable[index] = s->i;
			 rpltab(CSD,&Xsdc);
		}
		else ctable[index] = s->i;

		break;

	}
	return(tatom);
}