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

# include "global.h"
# include <a.out.h>

/************************************************************************/
/*									*/
/*  Lalloc								*/
/*									*/
/*  This lambda allows allocation of pages from lisp.  The first	*/
/*  argument is the name of a space, n pages of which are allocated,	*/
/*  if possible.  Returns the number of pages allocated.		*/

lispval
Lalloc()
	{
	int n;
	register struct argent *mylbot = lbot;
	snpand(1);
	chkarg(2);
	if(TYPE((mylbot+1)->val) != INT && (mylbot+1)->val != nil )
		error("2nd ARGUMENT TO ALLOCATE MUST BE AN INTEGER",FALSE);
	n = 1;
	if((mylbot+1)->val != nil) n = (mylbot+1)->val->i;
	return(alloc((mylbot)->val,n));	/*  call alloc to do the work  */
	}

lispval
Lsizeof()
	{
	chkarg(1);
	return(inewint(csizeof(lbot->val)));
	}

lispval
Lsegment()
	{
	chkarg(2);
chek:	while(TYPE(np[-1].val) != INT )
		np[-1].val=error("LENGTH ARG TO SEGMENT MUST BE INTEGER",TRUE);
	if( np[-1].val->i < 0 )
		{
		np[-1].val = error("LENGTH ARG TO SEGMENT MUST BE POSITIVE",TRUE);
		goto chek;
		}
	return(csegment((lbot)->val,np[-1].val->i));
	}

/*  Lforget  *************************************************************/
/*									*/
/*  This function removes an atom from the hash table.			*/

lispval
Lforget()
	{
	char c,*name;
	struct atom *buckpt;
	int hash;
	chkarg(1);
	if(TYPE(lbot->val) != ATOM)
		error("CANNOT FORGET NON-ATOM",FALSE);
	name = lbot->val->pname;
	hash = 0;
	while( (c = *name++) != NULL_CHAR) hash ^= c;
	hash = hash & 0177;

	/*  We have found the hash bucket for the atom, now we remove it  */

	if( hasht[hash] == (struct atom *)lbot->val )
		{
		hasht[hash] = lbot->val->hshlnk;
		lbot->val->hshlnk = (struct atom *)CNIL;
		return(lbot->val);
		}

	buckpt = hasht[hash];
	while(buckpt != (struct atom *)CNIL)
		{
		if(buckpt->hshlnk == (struct atom *)lbot->val)
			{
			buckpt->hshlnk = lbot->val->hshlnk;
			lbot->val->hshlnk = (struct atom *)CNIL;
			return(lbot->val);
			}
		buckpt = buckpt->hshlnk;
		}

	/*  Whoops!  Guess it wasn't in the hash table after all.  */

	return(lbot->val);
	}

lispval
Lgetl()
	{
	chkarg(1);
	if(TYPE(lbot->val) != ARRAY)
		error("ARG TO GETLENGTH MUST BE AN ARRAY",TRUE);
	return(lbot->val->length);
	}

lispval
Lputl()
	{
	chkarg(2);
	if(TYPE((lbot)->val) != ARRAY)
		error("ARG TO PUTLENGTH MUST BE AN ARRAY",FALSE);
chek:	while(TYPE(np[-1].val) != INT)
		np[-1].val = error("ARRAY LENGTH MUST BE AN INTEGER",FALSE);
	if(np[-1].val->i <= 0)
		{
		np[-1].val = error("ARRAY LENGTH MUST BE POSITIVE",TRUE);
		goto chek;
		}
	return((lbot)->val->length = np[-1].val);
	}
lispval
Lgetdel()
	{
	chkarg(1);
	if(TYPE(lbot->val) != ARRAY)
		error("ARG TO GETDELTA MUST BE AN ARRAY",FALSE);
	return(lbot->val->delta);
	}

lispval
Lputdel()
	{
	chkarg(2);
	if(TYPE((np-2)->val) != ARRAY)
		error("ARG TO PUTDELTA MUST BE AN ARRAY",FALSE);
chek:	while(TYPE(np[-1].val) != INT)
		np[-1].val = error("ARRAY LENGTH MUST BE AN INTEGER",TRUE);
	if(np[-1].val->i <= 0)
		{
		np[-1].val = error("ARRAY DELTA MUST BE POSITIVE",TRUE);
		goto chek;
		}
	return((lbot)->val->delta = np[-1].val);
	}

lispval
Lgetaux()
	{
	chkarg(1);
	if(TYPE(lbot->val)!=ARRAY)
		error("ARG TO GETAUX MUST BE ARRAY",FALSE);
	return(lbot->val->aux);
	}

lispval
Lputaux()
	{
	chkarg(2);

	if(TYPE((lbot)->val)!=ARRAY)
		error("1st ARG TO PUTAUX MUST BBE ARRAY",FALSE);
	return((lbot)->val->aux = np[-1].val);
	}

lispval
Lgeta()
	{
	chkarg(1);
	if(TYPE(lbot->val) != ARRAY)
		error("ARG TO GETACCESS MUST BE AN ARRAY",FALSE);
	return(lbot->val->accfun);
	}

lispval
Lputa()
	{
	chkarg(2);
	if(TYPE((lbot)->val) != ARRAY)
		error("ARG TO PUTACCESS MUST BE ARRAY",FALSE);
	return((lbot)->val->accfun = np[-1].val);
	}

lispval
Lmarray()
{
	register struct argent *mylbot = lbot;
	register lispval handy;
	snpand(2);
	chkarg(5);
	(handy = newarray());		/*  get a new array cell  */
	handy->data=(char *)mylbot->val;/*  insert data address  */
	handy->accfun = mylbot[1].val;	/*  insert access function  */
	handy->aux = mylbot[2].val;	/*  insert aux data  */
	handy->length = mylbot[3].val;	/*  insert length  */
	handy->delta = mylbot[4].val;	/*  push delta arg  */
	return(handy);
	}

lispval
Lgetentry()
	{
	chkarg(1);
	if( TYPE(lbot->val) != BCD )
		error("ARG TO GETENTRY MUST BE FUNCTION",FALSE);
	return((lispval)(lbot->val->entry));
	}

lispval
Lgetlang()
	{
	chkarg(1);
	while(TYPE(lbot->val)!=BCD)
		lbot->val = error("ARG TO GETLANG MUST BE FUNCTION DESCRIPTOR",TRUE);
	return(lbot->val->language);
	}

lispval
Lputlang()
	{
	chkarg(2);
	while(TYPE((lbot)->val)!=BCD)
		lbot->val = error("FIRST ARG TO PUTLANG MUST BE FUNCTION DESCRIPTOR",TRUE);
	(lbot)->val->language = np[-1].val;
	return(np[-1].val);
	}

lispval
Lgetparams()
	{
	chkarg(1);
	if(TYPE(np[-1].val)!=BCD)
		error("ARG TO GETPARAMS MUST BE A FUNCTION DESCRIPTOR",FALSE);
	return(np[-1].val->params);
	}

lispval
Lputparams()
	{
	chkarg(2);
	if(TYPE((lbot)->val)!=BCD)
		error("1st ARG TO PUTPARAMS MUST BE FUNCTION DESCRIPTOR",FALSE);
	return((lbot)->val->params = np[-1].val);
	}

lispval
Lgetdisc()
	{
	chkarg(1);
	if(TYPE(np[-1].val) != BCD)
		error("ARGUMENT OF GETDISC MUST BE FUNCTION",FALSE);
	return(np[-1].val->discipline);
	}

lispval
Lputdisc()
	{
	chkarg(2);
	if(TYPE(np[-2].val) != BCD)
		error("ARGUMENT OF PUTDISC MUST BE FUNCTION",FALSE);
	return((np-2)->val->discipline  = np[-1].val);
	}

lispval
Lgetloc()
	{
	chkarg(1);
	if(TYPE(lbot->val)!=BCD)
		error("ARGUMENT TO GETLOC MUST BE FUNCTION",FALSE);
	return(lbot->val->loctab);
	}

lispval
Lputloc()
	{
	chkarg(2);
	if(TYPE((lbot+1)->val)!=BCD);
		error("FIRST ARGUMENT TO PUTLOC MUST BE FUNCTION",FALSE);
	(lbot)->val->loctab = (lbot+1)->val;
	return((lbot+1)->val);
	}

lispval
Lmfunction()
	{
	register lispval handy;
	chkarg(5);
	handy = (newfunct());	/*  get a new function cell  */
	handy->entry = (lispval (*)())((np-5)->val);	/* insert entry point */
	handy->discipline = ((np-4)->val); /*  insert discipline  */
#ifdef ROWAN
	handy->language = (np-3)->val;  /*  insert language  */
	handy->params = ((np-2)->val);     /*  insert parameters  */
	handy->loctab = ((np-1)->val);	/*  insert local table  */
#endif
	return(handy);
	}

/** Lreplace ************************************************************/
/*									*/
/*  Destructively modifies almost any kind of data.		 	*/

lispval
Lreplace()
	{
	register lispval a1, a2;
	register int t;
	chkarg(2);

	if((t = TYPE(a1 = (lbot)->val)) != TYPE(a2 = np[-1].val))
		error("REPLACE ARGS MUST BE SAME TYPE",FALSE);

	switch( t )
		{
	case ATOM:	error("REPLACE CANNOT STORE ATOMS",FALSE);

	case VALUE:	a1->l = a2->l;
			return( a1 );

	case INT:	a1->i = a2->i;
			return( a1 );

	case STRNG:	error("STORE CANNOT STORE STRINGS",FALSE);

	case ARRAY:	a1->data = a2->data;
			a1->accfun = a2->accfun;
			a1->length = a2->length;
			a1->delta = a2->delta;
			return( a1 );

	case DOUB:	a1->r = a2->r;
			return( a1 );

	case SDOT:
	case DTPR:	a1->car = a2->car;
			a1->cdr = a2->cdr;
			return( a1 );
	case BCD:	a1->entry = a2->entry;
			a1->discipline = a2->discipline;
			return( a1 );
		}
	/* NOT REACHED */
	}

/* Lvaluep */

lispval
Lvaluep()
	{
	chkarg(1);
	if( TYPE(lbot->val) == VALUE ) return(tatom); else return(nil);
	}

CNTTYP() { return; /* HI! COUNT ONE TYPE CALL! */ }

lispval
Lod()
	{
	int i;
	chkarg(2);

	while( TYPE(np[-1].val) != INT )
		np[-1].val = error("2nd ARG TO OD MUST BE INTEGER",TRUE);

	for( i = 0; i < np->val->i; ++i )
		printf(copval(odform,CNIL)->pname,(int *)(np[-2].val)[i]);

	dmpport(poport);
	return(nil);
	}
lispval
Lfake()
	{
	chkarg(1);

	if( TYPE(lbot->val) != INT )
		error("ARG TO FAKE MUST BE INTEGER",TRUE);

	return((lispval)(lbot->val->i));
	}

lispval
Lwhat()
	{
	chkarg(1);
	return(inewint((int)(lbot->val)));
	}

lispval
Lpname()
	{
	chkarg(1);
	if(TYPE(lbot->val) != ATOM)
		error("ARG TO PNAME MUST BE AN ATOM",FALSE);
	return((lispval)(lbot->val->pname));
	}

lispval
Larrayref()
	{
	chkarg(2);
	if(TYPE((lbot)->val) != ARRAY)
		error("FIRST ARG TO ARRAYREF MUST BE ARRAY",FALSE);
	vtemp = (lbot + 1)->val;
chek:	while(TYPE(vtemp) != INT)
		vtemp = error("SECOND ARG TO ARRAYREF MUST BE INTEGER",TRUE);
	if( vtemp->i < 0 )
		{
		vtemp = error("NEGATIVE ARRAY OFFSET",TRUE);
		goto chek;
		}
	if( vtemp->i >= (np-2)->val->length->i )
		{
		vtemp = error("ARRAY OFFSET TOO LARGE",TRUE);
		goto chek;
		}
	vtemp = (lispval)((np-2)->val->data + ((np-2)->val->delta->i)*(vtemp->i));
		/*  compute address of desired item  */
	return(vtemp);
			
	}

lispval
Lptr()
	{
	chkarg(1);
	return(inewval(lbot->val));
	}

lispval
Llctrace()
	{
	chkarg(1);
	lctrace = (int)(lbot->val->clb);
	return((lispval)lctrace);
	}

lispval
Lslevel()
	{
	return(inewint(np-orgnp-2));
	}

lispval
Lsimpld()
	{
	register lispval pt;
	register char *cpt = strbuf;

	chkarg(1);

	for(atmlen=1, pt=np->val; NOTNIL(pt); ++atmlen, pt = pt->cdr);

	if( atmlen > STRBLEN )
		{
		error("LCODE WAS TOO LONG",TRUE);
		return((lispval)inewstr(""));
		}

	for(pt=np->val; NOTNIL(pt); pt = pt->cdr) *(cpt++) = pt->car->i;
	*cpt = 0;

	return((lispval)newstr());
	}
	
	
/*  Lopval  *************************************************************/
/*									*/
/*  Routine which allows system registers and options to be examined	*/
/*  and modified.  Calls copval, the routine which is called by c code	*/
/*  to do the same thing from inside the system.			*/

lispval 
Lopval()
	{
	lispval quant;
	snpand(0);

	if( lbot == np )
		return(error("BAD CALL TO OPVAL",TRUE));
	quant = lbot->val;	 /*  get name of sys variable  */
	while( TYPE(quant) != ATOM )
		quant = error("FIRST ARG TO OPVAL MUST BE AN ATOM",TRUE);

	if(np > lbot+1)  vtemp = (lbot+1)->val ;
	else vtemp = CNIL;
	return(copval(quant,vtemp));
}
Commit	Line	Data
4619ba6b JF	1	# include "global.h"
	2	# include <a.out.h>
	3
	4	/************************************************************************/
	5	/* */
	6	/* Lalloc */
	7	/* */
	8	/* This lambda allows allocation of pages from lisp. The first */
	9	/* argument is the name of a space, n pages of which are allocated, */
	10	/* if possible. Returns the number of pages allocated. */
	11
	12	lispval
	13	Lalloc()
	14	{
	15	int n;
	16	register struct argent *mylbot = lbot;
	17	snpand(1);
	18	chkarg(2);
	19	if(TYPE((mylbot+1)->val) != INT && (mylbot+1)->val != nil )
	20	error("2nd ARGUMENT TO ALLOCATE MUST BE AN INTEGER",FALSE);
	21	n = 1;
	22	if((mylbot+1)->val != nil) n = (mylbot+1)->val->i;
	23	return(alloc((mylbot)->val,n)); /* call alloc to do the work */
	24	}
	25
	26	lispval
	27	Lsizeof()
	28	{
	29	chkarg(1);
	30	return(inewint(csizeof(lbot->val)));
	31	}
	32
	33	lispval
	34	Lsegment()
	35	{
	36	chkarg(2);
	37	chek: while(TYPE(np[-1].val) != INT )
	38	np[-1].val=error("LENGTH ARG TO SEGMENT MUST BE INTEGER",TRUE);
	39	if( np[-1].val->i < 0 )
	40	{
	41	np[-1].val = error("LENGTH ARG TO SEGMENT MUST BE POSITIVE",TRUE);
	42	goto chek;
	43	}
	44	return(csegment((lbot)->val,np[-1].val->i));
	45	}
	46
	47	/* Lforget *************************************************************/
	48	/* */
	49	/* This function removes an atom from the hash table. */
	50
	51	lispval
	52	Lforget()
	53	{
	54	char c,*name;
	55	struct atom *buckpt;
	56	int hash;
	57	chkarg(1);
	58	if(TYPE(lbot->val) != ATOM)
	59	error("CANNOT FORGET NON-ATOM",FALSE);
	60	name = lbot->val->pname;
	61	hash = 0;
	62	while( (c = *name++) != NULL_CHAR) hash ^= c;
	63	hash = hash & 0177;
	64
65	/* We have found the hash bucket for the atom, now we remove it */
66
67	if( hasht[hash] == (struct atom *)lbot->val )
68	{
69	hasht[hash] = lbot->val->hshlnk;
70	lbot->val->hshlnk = (struct atom *)CNIL;
71	return(lbot->val);
72	}
73
74	buckpt = hasht[hash];
75	while(buckpt != (struct atom *)CNIL)
76	{
77	if(buckpt->hshlnk == (struct atom *)lbot->val)
78	{
79	buckpt->hshlnk = lbot->val->hshlnk;
80	lbot->val->hshlnk = (struct atom *)CNIL;
81	return(lbot->val);
82	}
83	buckpt = buckpt->hshlnk;
84	}
85
86	/* Whoops! Guess it wasn't in the hash table after all. */
87
88	return(lbot->val);
89	}
90
91	lispval
92	Lgetl()
93	{
94	chkarg(1);
95	if(TYPE(lbot->val) != ARRAY)
96	error("ARG TO GETLENGTH MUST BE AN ARRAY",TRUE);
97	return(lbot->val->length);
98	}
99
100	lispval
101	Lputl()
102	{
103	chkarg(2);
104	if(TYPE((lbot)->val) != ARRAY)
105	error("ARG TO PUTLENGTH MUST BE AN ARRAY",FALSE);
106	chek: while(TYPE(np[-1].val) != INT)
107	np[-1].val = error("ARRAY LENGTH MUST BE AN INTEGER",FALSE);
108	if(np[-1].val->i <= 0)
109	{
110	np[-1].val = error("ARRAY LENGTH MUST BE POSITIVE",TRUE);
111	goto chek;
112	}
113	return((lbot)->val->length = np[-1].val);
114	}
115	lispval
116	Lgetdel()
117	{
118	chkarg(1);
119	if(TYPE(lbot->val) != ARRAY)
120	error("ARG TO GETDELTA MUST BE AN ARRAY",FALSE);
121	return(lbot->val->delta);
122	}
123
124	lispval
125	Lputdel()
126	{
127	chkarg(2);
128	if(TYPE((np-2)->val) != ARRAY)
129	error("ARG TO PUTDELTA MUST BE AN ARRAY",FALSE);
130	chek: while(TYPE(np[-1].val) != INT)
131	np[-1].val = error("ARRAY LENGTH MUST BE AN INTEGER",TRUE);
132	if(np[-1].val->i <= 0)
133	{
134	np[-1].val = error("ARRAY DELTA MUST BE POSITIVE",TRUE);
135	goto chek;
136	}
137	return((lbot)->val->delta = np[-1].val);
138	}
139
140	lispval
141	Lgetaux()
142	{
143	chkarg(1);
144	if(TYPE(lbot->val)!=ARRAY)
145	error("ARG TO GETAUX MUST BE ARRAY",FALSE);
146	return(lbot->val->aux);
147	}
148
149	lispval
150	Lputaux()
151	{
152	chkarg(2);
153
154	if(TYPE((lbot)->val)!=ARRAY)
155	error("1st ARG TO PUTAUX MUST BBE ARRAY",FALSE);
156	return((lbot)->val->aux = np[-1].val);
157	}
158
159	lispval
160	Lgeta()
161	{
162	chkarg(1);
163	if(TYPE(lbot->val) != ARRAY)
164	error("ARG TO GETACCESS MUST BE AN ARRAY",FALSE);
165	return(lbot->val->accfun);
166	}
167
168	lispval
169	Lputa()
170	{
171	chkarg(2);
172	if(TYPE((lbot)->val) != ARRAY)
173	error("ARG TO PUTACCESS MUST BE ARRAY",FALSE);
174	return((lbot)->val->accfun = np[-1].val);
175	}
176
177	lispval
178	Lmarray()
179	{
180	register struct argent *mylbot = lbot;
181	register lispval handy;
182	snpand(2);
183	chkarg(5);
184	(handy = newarray()); /* get a new array cell */
185	handy->data=(char )mylbot->val;/ insert data address */
186	handy->accfun = mylbot[1].val; /* insert access function */
187	handy->aux = mylbot[2].val; /* insert aux data */
188	handy->length = mylbot[3].val; /* insert length */
189	handy->delta = mylbot[4].val; /* push delta arg */
190	return(handy);
191	}
192
193	lispval
194	Lgetentry()
195	{
196	chkarg(1);
197	if( TYPE(lbot->val) != BCD )
198	error("ARG TO GETENTRY MUST BE FUNCTION",FALSE);
199	return((lispval)(lbot->val->entry));
200	}
201
202	lispval
203	Lgetlang()
204	{
205	chkarg(1);
206	while(TYPE(lbot->val)!=BCD)
207	lbot->val = error("ARG TO GETLANG MUST BE FUNCTION DESCRIPTOR",TRUE);
208	return(lbot->val->language);
209	}
210
211	lispval
212	Lputlang()
213	{
214	chkarg(2);
215	while(TYPE((lbot)->val)!=BCD)
216	lbot->val = error("FIRST ARG TO PUTLANG MUST BE FUNCTION DESCRIPTOR",TRUE);
217	(lbot)->val->language = np[-1].val;
218	return(np[-1].val);
219	}
220
221	lispval
222	Lgetparams()
223	{
224	chkarg(1);
225	if(TYPE(np[-1].val)!=BCD)
226	error("ARG TO GETPARAMS MUST BE A FUNCTION DESCRIPTOR",FALSE);
227	return(np[-1].val->params);
228	}
229
230	lispval
231	Lputparams()
232	{
233	chkarg(2);
234	if(TYPE((lbot)->val)!=BCD)
235	error("1st ARG TO PUTPARAMS MUST BE FUNCTION DESCRIPTOR",FALSE);
236	return((lbot)->val->params = np[-1].val);
237	}
238
239	lispval
240	Lgetdisc()
241	{
242	chkarg(1);
243	if(TYPE(np[-1].val) != BCD)
244	error("ARGUMENT OF GETDISC MUST BE FUNCTION",FALSE);
245	return(np[-1].val->discipline);
246	}
247
248	lispval
249	Lputdisc()
250	{
251	chkarg(2);
252	if(TYPE(np[-2].val) != BCD)
253	error("ARGUMENT OF PUTDISC MUST BE FUNCTION",FALSE);
254	return((np-2)->val->discipline = np[-1].val);
255	}
256
257	lispval
258	Lgetloc()
259	{
260	chkarg(1);
261	if(TYPE(lbot->val)!=BCD)
262	error("ARGUMENT TO GETLOC MUST BE FUNCTION",FALSE);
263	return(lbot->val->loctab);
264	}
265
266	lispval
267	Lputloc()
268	{
269	chkarg(2);
270	if(TYPE((lbot+1)->val)!=BCD);
271	error("FIRST ARGUMENT TO PUTLOC MUST BE FUNCTION",FALSE);
272	(lbot)->val->loctab = (lbot+1)->val;
273	return((lbot+1)->val);
274	}
275
276	lispval
277	Lmfunction()
278	{
279	register lispval handy;
280	chkarg(5);
281	handy = (newfunct()); /* get a new function cell */
282	handy->entry = (lispval ()())((np-5)->val); / insert entry point */
283	handy->discipline = ((np-4)->val); /* insert discipline */
284	#ifdef ROWAN
285	handy->language = (np-3)->val; /* insert language */
286	handy->params = ((np-2)->val); /* insert parameters */
287	handy->loctab = ((np-1)->val); /* insert local table */
288	#endif
289	return(handy);
290	}
291
292	/ Lreplace **********************************************************/
293	/* */
294	/* Destructively modifies almost any kind of data. */
295
296	lispval
297	Lreplace()
298	{
299	register lispval a1, a2;
300	register int t;
301	chkarg(2);
302
303	if((t = TYPE(a1 = (lbot)->val)) != TYPE(a2 = np[-1].val))
304	error("REPLACE ARGS MUST BE SAME TYPE",FALSE);
305
306	switch( t )
307	{
308	case ATOM: error("REPLACE CANNOT STORE ATOMS",FALSE);
309
310	case VALUE: a1->l = a2->l;
311	return( a1 );
312
313	case INT: a1->i = a2->i;
314	return( a1 );
315
316	case STRNG: error("STORE CANNOT STORE STRINGS",FALSE);
317
318	case ARRAY: a1->data = a2->data;
319	a1->accfun = a2->accfun;
320	a1->length = a2->length;
321	a1->delta = a2->delta;
322	return( a1 );
323
324	case DOUB: a1->r = a2->r;
325	return( a1 );
326
327	case SDOT:
328	case DTPR: a1->car = a2->car;
329	a1->cdr = a2->cdr;
330	return( a1 );
331	case BCD: a1->entry = a2->entry;
332	a1->discipline = a2->discipline;
333	return( a1 );
334	}
335	/* NOT REACHED */
336	}
337
338	/* Lvaluep */
339
340	lispval
341	Lvaluep()
342	{
343	chkarg(1);
344	if( TYPE(lbot->val) == VALUE ) return(tatom); else return(nil);
345	}
346
347	CNTTYP() { return; /* HI! COUNT ONE TYPE CALL! */ }
348
349	lispval
350	Lod()
351	{
352	int i;
353	chkarg(2);
354
355	while( TYPE(np[-1].val) != INT )
356	np[-1].val = error("2nd ARG TO OD MUST BE INTEGER",TRUE);
357
358	for( i = 0; i < np->val->i; ++i )
359	printf(copval(odform,CNIL)->pname,(int *)(np[-2].val)[i]);
360
361	dmpport(poport);
362	return(nil);
363	}
364	lispval
365	Lfake()
366	{
367	chkarg(1);
368
369	if( TYPE(lbot->val) != INT )
370	error("ARG TO FAKE MUST BE INTEGER",TRUE);
371
372	return((lispval)(lbot->val->i));
373	}
374
375	lispval
376	Lwhat()
377	{
378	chkarg(1);
379	return(inewint((int)(lbot->val)));
380	}
381
382	lispval
383	Lpname()
384	{
385	chkarg(1);
386	if(TYPE(lbot->val) != ATOM)
387	error("ARG TO PNAME MUST BE AN ATOM",FALSE);
388	return((lispval)(lbot->val->pname));
389	}
390
391	lispval
392	Larrayref()
393	{
394	chkarg(2);
395	if(TYPE((lbot)->val) != ARRAY)
396	error("FIRST ARG TO ARRAYREF MUST BE ARRAY",FALSE);
397	vtemp = (lbot + 1)->val;
398	chek: while(TYPE(vtemp) != INT)
399	vtemp = error("SECOND ARG TO ARRAYREF MUST BE INTEGER",TRUE);
400	if( vtemp->i < 0 )
401	{
402	vtemp = error("NEGATIVE ARRAY OFFSET",TRUE);
403	goto chek;
404	}
405	if( vtemp->i >= (np-2)->val->length->i )
406	{
407	vtemp = error("ARRAY OFFSET TOO LARGE",TRUE);
408	goto chek;
409	}
410	vtemp = (lispval)((np-2)->val->data + ((np-2)->val->delta->i)*(vtemp->i));
411	/* compute address of desired item */
412	return(vtemp);
413
414	}
415
416	lispval
417	Lptr()
418	{
419	chkarg(1);
420	return(inewval(lbot->val));
421	}
422
423	lispval
424	Llctrace()
425	{
426	chkarg(1);
427	lctrace = (int)(lbot->val->clb);
428	return((lispval)lctrace);
429	}
430
431	lispval
432	Lslevel()
433	{
434	return(inewint(np-orgnp-2));
435	}
436
437	lispval
438	Lsimpld()
439	{
440	register lispval pt;
441	register char *cpt = strbuf;
442
443	chkarg(1);
444
445	for(atmlen=1, pt=np->val; NOTNIL(pt); ++atmlen, pt = pt->cdr);
446
447	if( atmlen > STRBLEN )
448	{
449	error("LCODE WAS TOO LONG",TRUE);
450	return((lispval)inewstr(""));
451	}
452
453	for(pt=np->val; NOTNIL(pt); pt = pt->cdr) *(cpt++) = pt->car->i;
454	*cpt = 0;
455
456	return((lispval)newstr());
457	}
458
459
460	/* Lopval *************************************************************/
461	/* */
462	/* Routine which allows system registers and options to be examined */
463	/* and modified. Calls copval, the routine which is called by c code */
464	/* to do the same thing from inside the system. */
465
466	lispval
467	Lopval()
468	{
469	lispval quant;
470	snpand(0);
471
472	if( lbot == np )
473	return(error("BAD CALL TO OPVAL",TRUE));
474	quant = lbot->val; /* get name of sys variable */
475	while( TYPE(quant) != ATOM )
476	quant = error("FIRST ARG TO OPVAL MUST BE AN ATOM",TRUE);
477
478	if(np > lbot+1) vtemp = (lbot+1)->val ;
479	else vtemp = CNIL;
480	return(copval(quant,vtemp));
481	}
482