[unix-history] / usr / src / cmd / lisp / lam6.c

#include "global.h"
FILE *
mkstFI(base,count,flag)
char *base;
char flag;
{
	register FILE *p = stderr;

	/* find free file descriptor */
	for(;p->_flag&(_IOREAD|_IOWRT);p++)
		if(p >= _iob + _NFILE)
			error("Too many open files to do readlist",FALSE);
	p->_flag = _IOSTRG | flag;
	p->_cnt = count;
	p->_base = base;
	p->_ptr = base;
	p->_file = -1;
	return(p);
}
lispval
Lreadli()
{
	register lispval work, handy;
	register FILE *p;
	register char *string;
	register struct argent *lbot, *np;
	struct argent *olbot;
	FILE *opiport = piport;
	lispval Lread();
	int count;

	chkarg(1);
	if(lbot->val==nil) {		/*effectively, return(matom(""));*/
		strbuf[0] = 0;
		return(getatom());
	}
	count = 1;

	/* compute length of list */
	for(work = lbot->val; TYPE(work)==DTPR; work=work->cdr)
		count++;
	string = (char *) alloca(count);
	p = mkstFI(string, count - 1, _IOREAD);
	for(work = lbot->val; TYPE(work)==DTPR; work=work->cdr) {
		handy = work->car;
		switch(TYPE(handy)) {
		case SDOT:
		case INT:
			*string++=handy->i;
			break;
		case ATOM:
			*string++ = *(handy->pname);
			break;
		default:
			error("Non atom or int to readlist",FALSE);
		}
	}
	*string = 0;
	olbot = lbot;
	lbot = np;
	protect(P(p));
	work = Lread();
	lbot = olbot;
	frstFI(p);
	return(work);
}
frstFI(p)
register FILE *p;
{
	p->_flag=0;
	p->_base=0;
	p->_cnt = 0;
	p->_ptr = 0;
	p->_file = 0;
}
lispval
Lgetenv()
{
	register struct argent *mylbot=lbot;
	snpand(1);
	if((TYPE(mylbot->val))!=ATOM)
		error("argument to getenv must be atom",FALSE);

	strcpy(strbuf,getenv(mylbot->val->pname));
	return(getatom());
}
lispval
Lboundp()
{
	register struct argent *mynp=lbot;
	register lispval result, handy;
	snpand(3);

	if((TYPE(mynp->val))!=ATOM)
		error("argument to boundp must be atom",FALSE);
	if( (handy = mynp->val)->clb==CNIL)
		result = nil;
	else
		(result = newdot())->cdr = handy->clb;
	return(result);
}
lispval
Lplist()
{	
	register lispval atm;
	snpand(0);
	/* get property list of an atom or disembodied property list */

	chkarg(1);
	atm = lbot->val;
	switch(TYPE(atm)) {
	case ATOM:
	case DTPR:
		break;
	default:
		error("Only Atoms and disembodied property lists allowed for plist",FALSE);
	}
	if(atm==nil) return(nilplist);
	return(atm->plist);
}
lispval
Lsetpli()
{	/* set the property list of the given atom to the given list */
	register lispval atm, vall;
	register lispval dum1, dum2;
	register struct argent *lbot, *np;
	snpand(2);

	chkarg(2);
	atm = lbot->val;
	if (TYPE(atm) != ATOM) error("First argument must be an atom",FALSE);
	vall = (np-1)->val;
	if (TYPE(vall)!= DTPR && vall !=nil)
	    error("Second argument must be a list",FALSE);
	if (atm==nil)
		nilplist = vall;
	else
		atm->plist = vall;
	return(vall);
}

lispval
Lsignal()
{
	register struct argent *mylbot = lbot;
	extern lispval sigacts[16];
	int i; register lispval handy, old;
	chkarg(2);

	handy = mylbot[AD].val;
	if(TYPE(handy)!=INT)
		error("First arg to signal must be an int",FALSE);
	i = handy->i & 15;
	handy = mylbot[AD+1].val;
	if(TYPE(handy)!=ATOM)
		error("Second arg to signal must be an atom",FALSE);
	old = sigacts[i];
	if(old==0) old = nil;
	if(handy==nil)
		sigacts[i]=((lispval) 0);
	else
		sigacts[i]=handy;
	return(old);
}
lispval
Lassq()
{
	register lispval work, handy, dum1, dum2;
	register struct argent *lbot, *np;
	snpand(2);

	chkarg(2);
	for(work = lbot[AD+1].val;
		work->car->car!=lbot->val&& work!=nil;
		work = work->cdr);
	return(work->car);
}
lispval
Lkilcopy()
{
	if(fork()==0) {
		asm(".byte 0");
	}
}
lispval
Larg()
{
	register lispval handy; register offset, count;
	snpand(3);

	handy = lexpr_atom->clb;
	if(handy==CNIL || TYPE(handy)!=DTPR)
		error("Arg: not in context of Lexpr.",FALSE);
	count = ((long *)handy->cdr) - (long *)handy->car;
	if(np==lbot || lbot->val==nil)
		return(inewint(count));
	if(TYPE(lbot->val)!=INT || (offset = lbot->val->i - 1) > count || offset < 0 )
		error("Out of bonds: arg to \"Arg\"",FALSE);
	return( ((struct argent *)handy->car)[offset].val);
}
lispval
Lptime(){
	extern int GCtime;
	int lgctime = GCtime;
	static struct tbuf {
		long	mytime;
		long	allelse[3];
	} current;
	register lispval result, handy;

	snpand(2);
	times(&current);
	result = newdot();
	handy = result;
	protect(result);
	result->cdr = newdot();
	result->car = inewint(current.mytime);
	handy = result->cdr;
	handy->car = inewint(lgctime);
	handy->cdr = nil;
	if(GCtime==0)
		GCtime = 1;
	return(result);
}

/* (err [value] [flag]) 
   where if value is present, it is the value to throw to the errset.
   flag if present must evaluate to nil, as we always evaluate value
   before unwinding stack
 */

lispval Lerr()
{
	register lispval handy;
	lispval errorh();
	char *mesg = "call to err";  /* default message */

	chkarg(1);

	if ((np >= lbot + 2) && ((lbot+1)->val != nil))
		error("Second arg to err must be nil",FALSE);
	if ((lbot->val != nil) && (TYPE(lbot->val) == ATOM))
	    mesg = lbot->val->pname;		/* new message if atom */
				
	return(errorh(Vererr,mesg,lbot->val,nil));
}
lispval
Ltyi()
{
	register FILE *port;
	register char val;

	chkarg(1);
	port = okport(lbot->val,okport(Vpiport->clb,stdin));


	fflush(stdout);		/* flush any pending output characters */
	val = getc(port);
	return(inewint(val));
}
lispval
Ltyipeek()
{
	register FILE *port;
	register char val;

	chkarg(1);
	port = okport(lbot->val,okport(Vpiport->clb,stdin));

	fflush(stdout);		/* flush any pending output characters */
	val = getc(port);
	ungetc(val,port);
	return(inewint(val));
}
lispval
Ltyo()
{
	register FILE *port;
	register lispval handy, where;
	register char val;
	register struct argent *lbot, *np;

	chkarg(2);
	handy = lbot->val;
	if(TYPE(handy)!=INT)
		error("Tyo demands number for 1st arg",FALSE);
	val = handy->i;

	where = lbot[1].val;
	port = (FILE *) okport(where,okport(Vpoport->clb,stdout));
	putc(val,port);
	return(handy);
}
lispval
Imkrtab(current)
{
	extern struct rtab {
		char ctable[132];
	} initread;
	register lispval handy; extern lispval lastrtab;
	static int cycle = 0;
	static char *nextfree;
	if((cycle++)%3==0) {
		nextfree = (char *) csegment(int_name,128);
	}
	handy = newarray();
	handy->data = nextfree;
	if(current == 0)
		*(struct rtab *)nextfree = initread;
	else
		*(struct rtab *)nextfree = *(struct rtab *)ctable;
	handy->delta = inewint(4);
	handy->length = inewint(sizeof(struct rtab)/sizeof(int));
	handy->accfun = handy->aux  = nil;
	nextfree += sizeof(struct rtab);
	return(handy);
}

/* makereadtable - arg : t or nil
	returns a readtable, t means return a copy of the initial readtable

			     nil means return a copy of the current readtable
*/
lispval
Lmakertbl()
{
	if(lbot==np) error("makereadtable: wrong number of args",FALSE);

	if(TYPE(lbot->val) != ATOM) 
		error("makereadtable: arg must be atom",FALSE);

	if(lbot->val == nil) return(Imkrtab(1));
	else return(Imkrtab(0));
}
lispval
Lcpy1()
{
	register lispval handy = lbot->val, result = handy;

top:
	switch(TYPE(handy))
	{
	case INT:
		result = inewint(handy->i);
		break;
	case VALUE:
		(result = newval())->l = handy->l;
		break;
	case DOUB:
		(result = newdoub())->r = handy->r;
		break;
	default:
		lbot->val =
		    errorh(Vermisc,"Bad arg to cpy1",nil,TRUE,67,handy);
		goto top;
	}
	return(result);
}
Commit	Line	Data
a22cc832 JF	1	#include "global.h"
	2	FILE *
	3	mkstFI(base,count,flag)
	4	char *base;
	5	char flag;
	6	{
	7	register FILE *p = stderr;
	8
	9	/* find free file descriptor */
	10	for(;p->_flag&(_IOREAD\|_IOWRT);p++)
	11	if(p >= _iob + _NFILE)
	12	error("Too many open files to do readlist",FALSE);
	13	p->_flag = _IOSTRG \| flag;
	14	p->_cnt = count;
	15	p->_base = base;
	16	p->_ptr = base;
	17	p->_file = -1;
	18	return(p);
	19	}
	20	lispval
	21	Lreadli()
	22	{
	23	register lispval work, handy;
	24	register FILE *p;
	25	register char *string;
	26	register struct argent lbot, np;
	27	struct argent *olbot;
	28	FILE *opiport = piport;
	29	lispval Lread();
	30	int count;
	31
	32	chkarg(1);
	33	if(lbot->val==nil) { /effectively, return(matom(""));/
	34	strbuf[0] = 0;
	35	return(getatom());
	36	}
	37	count = 1;
	38
	39	/* compute length of list */
	40	for(work = lbot->val; TYPE(work)==DTPR; work=work->cdr)
	41	count++;
	42	string = (char *) alloca(count);
	43	p = mkstFI(string, count - 1, _IOREAD);
	44	for(work = lbot->val; TYPE(work)==DTPR; work=work->cdr) {
	45	handy = work->car;
	46	switch(TYPE(handy)) {
	47	case SDOT:
	48	case INT:
	49	*string++=handy->i;
	50	break;
	51	case ATOM:
	52	string++ = (handy->pname);
	53	break;
	54	default:
	55	error("Non atom or int to readlist",FALSE);
	56	}
	57	}
	58	*string = 0;
	59	olbot = lbot;
	60	lbot = np;
	61	protect(P(p));
	62	work = Lread();
	63	lbot = olbot;
	64	frstFI(p);
65	return(work);
66	}
67	frstFI(p)
68	register FILE *p;
69	{
70	p->_flag=0;
71	p->_base=0;
72	p->_cnt = 0;
73	p->_ptr = 0;
74	p->_file = 0;
75	}
76	lispval
77	Lgetenv()
78	{
79	register struct argent *mylbot=lbot;
80	snpand(1);
81	if((TYPE(mylbot->val))!=ATOM)
82	error("argument to getenv must be atom",FALSE);
83
84	strcpy(strbuf,getenv(mylbot->val->pname));
85	return(getatom());
86	}
87	lispval
88	Lboundp()
89	{
90	register struct argent *mynp=lbot;
91	register lispval result, handy;
92	snpand(3);
93
94	if((TYPE(mynp->val))!=ATOM)
95	error("argument to boundp must be atom",FALSE);
96	if( (handy = mynp->val)->clb==CNIL)
97	result = nil;
98	else
99	(result = newdot())->cdr = handy->clb;
100	return(result);
101	}
102	lispval
103	Lplist()
104	{
105	register lispval atm;
106	snpand(0);
107	/* get property list of an atom or disembodied property list */
108
109	chkarg(1);
110	atm = lbot->val;
111	switch(TYPE(atm)) {
112	case ATOM:
113	case DTPR:
114	break;
115	default:
116	error("Only Atoms and disembodied property lists allowed for plist",FALSE);
117	}
118	if(atm==nil) return(nilplist);
119	return(atm->plist);
120	}
121	lispval
122	Lsetpli()
123	{ /* set the property list of the given atom to the given list */
124	register lispval atm, vall;
125	register lispval dum1, dum2;
126	register struct argent lbot, np;
127	snpand(2);
128
129	chkarg(2);
130	atm = lbot->val;
131	if (TYPE(atm) != ATOM) error("First argument must be an atom",FALSE);
132	vall = (np-1)->val;
133	if (TYPE(vall)!= DTPR && vall !=nil)
134	error("Second argument must be a list",FALSE);
135	if (atm==nil)
136	nilplist = vall;
137	else
138	atm->plist = vall;
139	return(vall);
140	}
141
142	lispval
143	Lsignal()
144	{
145	register struct argent *mylbot = lbot;
146	extern lispval sigacts[16];
147	int i; register lispval handy, old;
148	chkarg(2);
149
150	handy = mylbot[AD].val;
151	if(TYPE(handy)!=INT)
152	error("First arg to signal must be an int",FALSE);
153	i = handy->i & 15;
154	handy = mylbot[AD+1].val;
155	if(TYPE(handy)!=ATOM)
156	error("Second arg to signal must be an atom",FALSE);
157	old = sigacts[i];
158	if(old==0) old = nil;
159	if(handy==nil)
160	sigacts[i]=((lispval) 0);
161	else
162	sigacts[i]=handy;
163	return(old);
164	}
165	lispval
166	Lassq()
167	{
168	register lispval work, handy, dum1, dum2;
169	register struct argent lbot, np;
170	snpand(2);
171
172	chkarg(2);
173	for(work = lbot[AD+1].val;
174	work->car->car!=lbot->val&& work!=nil;
175	work = work->cdr);
176	return(work->car);
177	}
178	lispval
179	Lkilcopy()
180	{
181	if(fork()==0) {
182	asm(".byte 0");
183	}
184	}
185	lispval
186	Larg()
187	{
188	register lispval handy; register offset, count;
189	snpand(3);
190
191	handy = lexpr_atom->clb;
192	if(handy==CNIL \|\| TYPE(handy)!=DTPR)
193	error("Arg: not in context of Lexpr.",FALSE);
194	count = ((long )handy->cdr) - (long )handy->car;
195	if(np==lbot \|\| lbot->val==nil)
196	return(inewint(count));
197	if(TYPE(lbot->val)!=INT \|\| (offset = lbot->val->i - 1) > count \|\| offset < 0 )
198	error("Out of bonds: arg to \"Arg\"",FALSE);
199	return( ((struct argent *)handy->car)[offset].val);
200	}
201	lispval
202	Lptime(){
203	extern int GCtime;
204	int lgctime = GCtime;
205	static struct tbuf {
206	long mytime;
207	long allelse[3];
208	} current;
209	register lispval result, handy;
210
211	snpand(2);
212	times(&current);
213	result = newdot();
214	handy = result;
215	protect(result);
216	result->cdr = newdot();
217	result->car = inewint(current.mytime);
218	handy = result->cdr;
219	handy->car = inewint(lgctime);
220	handy->cdr = nil;
221	if(GCtime==0)
222	GCtime = 1;
223	return(result);
224	}
225
226	/* (err [value] [flag])
227	where if value is present, it is the value to throw to the errset.
228	flag if present must evaluate to nil, as we always evaluate value
229	before unwinding stack
230	*/
231
232	lispval Lerr()
233	{
234	register lispval handy;
235	lispval errorh();
236	char mesg = "call to err"; / default message */
237
238	chkarg(1);
239
240	if ((np >= lbot + 2) && ((lbot+1)->val != nil))
241	error("Second arg to err must be nil",FALSE);
242	if ((lbot->val != nil) && (TYPE(lbot->val) == ATOM))
243	mesg = lbot->val->pname; /* new message if atom */
244
245	return(errorh(Vererr,mesg,lbot->val,nil));
246	}
247	lispval
248	Ltyi()
249	{
250	register FILE *port;
251	register char val;
252
253	chkarg(1);
254	port = okport(lbot->val,okport(Vpiport->clb,stdin));
255
256
257	fflush(stdout); /* flush any pending output characters */
258	val = getc(port);
259	return(inewint(val));
260	}
261	lispval
262	Ltyipeek()
263	{
264	register FILE *port;
265	register char val;
266
267	chkarg(1);
268	port = okport(lbot->val,okport(Vpiport->clb,stdin));
269
270	fflush(stdout); /* flush any pending output characters */
271	val = getc(port);
272	ungetc(val,port);
273	return(inewint(val));
274	}
275	lispval
276	Ltyo()
277	{
278	register FILE *port;
279	register lispval handy, where;
280	register char val;
281	register struct argent lbot, np;
282
283	chkarg(2);
284	handy = lbot->val;
285	if(TYPE(handy)!=INT)
286	error("Tyo demands number for 1st arg",FALSE);
287	val = handy->i;
288
289	where = lbot[1].val;
290	port = (FILE *) okport(where,okport(Vpoport->clb,stdout));
291	putc(val,port);
292	return(handy);
293	}
294	lispval
295	Imkrtab(current)
296	{
297	extern struct rtab {
298	char ctable[132];
299	} initread;
300	register lispval handy; extern lispval lastrtab;
301	static int cycle = 0;
302	static char *nextfree;
303	if((cycle++)%3==0) {
304	nextfree = (char *) csegment(int_name,128);
305	}
306	handy = newarray();
307	handy->data = nextfree;
308	if(current == 0)
309	(struct rtab )nextfree = initread;
310	else
311	(struct rtab )nextfree = (struct rtab )ctable;
312	handy->delta = inewint(4);
313	handy->length = inewint(sizeof(struct rtab)/sizeof(int));
314	handy->accfun = handy->aux = nil;
315	nextfree += sizeof(struct rtab);
316	return(handy);
317	}
318
319	/* makereadtable - arg : t or nil
320	returns a readtable, t means return a copy of the initial readtable
321
322	nil means return a copy of the current readtable
323	*/
324	lispval
325	Lmakertbl()
326	{
327	if(lbot==np) error("makereadtable: wrong number of args",FALSE);
328
329	if(TYPE(lbot->val) != ATOM)
330	error("makereadtable: arg must be atom",FALSE);
331
332	if(lbot->val == nil) return(Imkrtab(1));
333	else return(Imkrtab(0));
334	}
335	lispval
336	Lcpy1()
337	{
338	register lispval handy = lbot->val, result = handy;
339
340	top:
341	switch(TYPE(handy))
342	{
343	case INT:
344	result = inewint(handy->i);
345	break;
346	case VALUE:
347	(result = newval())->l = handy->l;
348	break;
349	case DOUB:
350	(result = newdoub())->r = handy->r;
351	break;
352	default:
353	lbot->val =
354	errorh(Vermisc,"Bad arg to cpy1",nil,TRUE,67,handy);
355	goto top;
356	}
357	return(result);
358	}