![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to lamr.c CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 43BSDTahoe / ucb / lisp / franz|
Return to lamr.c CVS log | Up to [CSRG BSD Unix] / 43BSDTahoe / ucb / lisp / franz |
1.1 root 1: #ifndef lint
2: static char *rcsid =
3: "$Header: lamr.c,v 1.6 84/04/06 23:14:05 layer Exp $";
4: #endif
5:
6: /* -[Sat Jan 29 13:09:59 1983 by jkf]-
7: * lamr.c $Locker: $
8: * lambda functions
9: *
10: * (c) copyright 1982, Regents of the University of California
11: */
12:
13: # include "global.h"
14:
15: /*
16: *
17: * Lalloc
18: *
19: * This lambda allows allocation of pages from lisp. The first
20: * argument is the name of a space, n pages of which are allocated,
21: * if possible. Returns the number of pages allocated.
22: */
23:
24: lispval
25: Lalloc()
26: {
27: long n;
28: chkarg(2,"alloc");
29: if(TYPE((lbot+1)->val) != INT && (lbot+1)->val != nil )
30: error("2nd argument to allocate must be an integer",FALSE);
31: n = 1;
32: if((lbot+1)->val != nil) n = (lbot+1)->val->i;
33: return(alloc((lbot)->val,n)); /* call alloc to do the work */
34: }
35:
36: lispval
37: Lsizeof()
38: {
39: chkarg(1,"sizeof");
40: return(inewint(csizeof(lbot->val)));
41: }
42:
43: lispval
44: Lsegment()
45: {
46: chkarg(2,"segment");
47: chek: while(TYPE(np[-1].val) != INT )
48: np[-1].val=error("LENGTH ARG TO SEGMENT MUST BE INTEGER",TRUE);
49: if( np[-1].val->i < 0 )
50: {
51: np[-1].val = error("LENGTH ARG TO SEGMENT MUST BE POSITIVE",TRUE);
52: goto chek;
53: }
54: return(csegment(typenum((lbot)->val),(int)(np[-1].val->i),FALSE));
55: }
56:
57: /* Lforget *************************************************************/
58: /* */
59: /* This function removes an atom from the hash table. */
60:
61: lispval
62: Lforget()
63: {
64: char *name;
65: struct atom *buckpt;
66: int hash;
67: chkarg(1,"forget");
68: if(TYPE(lbot->val) != ATOM)
69: error("remob: non-atom argument",FALSE);
70: name = lbot->val->a.pname;
71: hash = hashfcn(name);
72:
73: /* We have found the hash bucket for the atom, now we remove it */
74:
75: if( hasht[hash] == (struct atom *)lbot->val )
76: {
77: hasht[hash] = lbot->val->a.hshlnk;
78: lbot->val->a.hshlnk = (struct atom *)CNIL;
79: return(lbot->val);
80: }
81:
82: buckpt = hasht[hash];
83: while(buckpt != (struct atom *)CNIL)
84: {
85: if(buckpt->hshlnk == (struct atom *)lbot->val)
86: {
87: buckpt->hshlnk = lbot->val->a.hshlnk;
88: lbot->val->a.hshlnk = (struct atom *)CNIL;
89: return(lbot->val);
90: }
91: buckpt = buckpt->hshlnk;
92: }
93:
94: /* Whoops! Guess it wasn't in the hash table after all. */
95:
96: return(lbot->val);
97: }
98:
99: lispval
100: Lgetl()
101: {
102: chkarg(1,"getlength");
103: if(TYPE(lbot->val) != ARRAY)
104: error("ARG TO GETLENGTH MUST BE AN ARRAY",TRUE);
105: return(lbot->val->ar.length);
106: }
107:
108: lispval
109: Lputl()
110: {
111: chkarg(2,"putlength");
112: if(TYPE((lbot)->val) != ARRAY)
113: error("ARG TO PUTLENGTH MUST BE AN ARRAY",FALSE);
114: chek: while(TYPE(np[-1].val) != INT)
115: np[-1].val = error("ARRAY LENGTH MUST BE AN INTEGER",FALSE);
116: if(np[-1].val->i <= 0)
117: {
118: np[-1].val = error("ARRAY LENGTH MUST BE POSITIVE",TRUE);
119: goto chek;
120: }
121: return((lbot)->val->ar.length = np[-1].val);
122: }
123: lispval
124: Lgetdel()
125: {
126: chkarg(1,"getdelta");
127: if(TYPE(lbot->val) != ARRAY)
128: error("ARG TO GETDELTA MUST BE AN ARRAY",FALSE);
129: return(lbot->val->ar.delta);
130: }
131:
132: lispval
133: Lputdel()
134: {
135: chkarg(2,"putdelta");
136: if(TYPE((np-2)->val) != ARRAY)
137: error("ARG TO PUTDELTA MUST BE AN ARRAY",FALSE);
138: chek: while(TYPE(np[-1].val) != INT)
139: np[-1].val = error("ARRAY LENGTH MUST BE AN INTEGER",TRUE);
140: if(np[-1].val->i <= 0)
141: {
142: np[-1].val = error("Array delta must be positive",TRUE);
143: goto chek;
144: }
145: return((lbot)->val->ar.delta = np[-1].val);
146: }
147:
148: lispval
149: Lgetaux()
150: {
151: chkarg(1,"getaux");
152: if(TYPE(lbot->val)!=ARRAY)
153: error("Arg to getaux must be an array", FALSE);
154: return(lbot->val->ar.aux);
155: }
156:
157: lispval
158: Lputaux()
159: {
160: chkarg(2,"putaux");
161:
162: if(TYPE((lbot)->val)!=ARRAY)
163: error("1st Arg to putaux must be array", FALSE);
164: return((lbot)->val->ar.aux = np[-1].val);
165: }
166:
167: lispval
168: Lgetdata()
169: {
170: chkarg(1,"getdata");
171: if(TYPE(lbot->val)!=ARRAY)
172: error("Arg to getdata must be an array", FALSE);
173: return((lispval)lbot->val->ar.data);
174: }
175:
176: lispval
177: Lputdata()
178: {
179: chkarg(2,"putdata");
180:
181: if(TYPE(lbot->val)!=ARRAY)
182: error("1st Arg to putaux must be array", FALSE);
183: return((lispval)(lbot->val->ar.data = (char *)(lbot[1].val)));
184: }
185:
186: lispval
187: Lgeta()
188: {
189: chkarg(1,"getaccess");
190: if(TYPE(lbot->val) != ARRAY)
191: error("ARG TO GETACCESS MUST BE AN ARRAY",FALSE);
192: return(lbot->val->ar.accfun);
193: }
194:
195: lispval
196: Lputa()
197: {
198: chkarg(2,"putaccess");
199: if(TYPE((lbot)->val) != ARRAY)
200: error("ARG TO PUTACCESS MUST BE ARRAY",FALSE);
201: return((lbot)->val->ar.accfun = np[-1].val);
202: }
203:
204: lispval
205: Lmarray()
206: {
207: register lispval handy;
208:
209: chkarg(5,"marray");
210:
211: (handy = newarray()); /* get a new array cell */
212: handy->ar.data=(char *)lbot->val;/* insert data address */
213: handy->ar.accfun = lbot[1].val; /* insert access function */
214: handy->ar.aux = lbot[2].val; /* insert aux data */
215: handy->ar.length = lbot[3].val; /* insert length */
216: handy->ar.delta = lbot[4].val; /* push delta arg */
217: return(handy);
218: }
219:
220: lispval
221: Lgtentry()
222: {
223: chkarg(1,"getentry");
224: if( TYPE(lbot->val) != BCD )
225: error("ARG TO GETENTRY MUST BE FUNCTION",FALSE);
226: return((lispval)(lbot->val->bcd.start));
227: }
228:
229: lispval
230: Lgetlang()
231: {
232: chkarg(1,"getlang");
233: while(TYPE(lbot->val)!=BCD)
234: lbot->val = error("ARG TO GETLANG MUST BE FUNCTION DESCRIPTOR",TRUE);
235: return(lbot->val->bcd.language);
236: }
237:
238: lispval
239: Lputlang()
240: {
241: chkarg(2,"putlang");
242: while(TYPE((lbot)->val)!=BCD)
243: lbot->val = error("FIRST ARG TO PUTLANG MUST BE FUNCTION DESCRIPTOR",TRUE);
244: (lbot)->val->bcd.language = np[-1].val;
245: return(np[-1].val);
246: }
247:
248: lispval
249: Lgetparams()
250: {
251: chkarg(1,"getparams");
252: if(TYPE(np[-1].val)!=BCD)
253: error("ARG TO GETPARAMS MUST BE A FUNCTION DESCRIPTOR",FALSE);
254: return(np[-1].val->bcd.params);
255: }
256:
257: lispval
258: Lputparams()
259: {
260: chkarg(2,"putparams");
261: if(TYPE((lbot)->val)!=BCD)
262: error("1st ARG TO PUTPARAMS MUST BE FUNCTION DESCRIPTOR",FALSE);
263: return((lbot)->val->bcd.params = np[-1].val);
264: }
265:
266: lispval
267: Lgetdisc()
268: {
269: chkarg(1,"getdisc");
270: if(TYPE(np[-1].val) != BCD)
271: error("ARGUMENT OF GETDISC MUST BE FUNCTION",FALSE);
272: return(np[-1].val->bcd.discipline);
273: }
274:
275: lispval
276: Lputdisc()
277: {
278: chkarg(2,"putdisc");
279: if(TYPE(np[-2].val) != BCD)
280: error("ARGUMENT OF PUTDISC MUST BE FUNCTION",FALSE);
281: return((np-2)->val->bcd.discipline = np[-1].val);
282: }
283:
284: lispval
285: Lgetloc()
286: {
287: chkarg(1,"getloc");
288: if(TYPE(lbot->val)!=BCD)
289: error("ARGUMENT TO GETLOC MUST BE FUNCTION",FALSE);
290: return(lbot->val->bcd.loctab);
291: }
292:
293: lispval
294: Lputloc()
295: {
296: chkarg(2,"putloc");
297: if(TYPE((lbot+1)->val)!=BCD);
298: error("FIRST ARGUMENT TO PUTLOC MUST BE FUNCTION",FALSE);
299: (lbot)->val->bcd.loctab = (lbot+1)->val;
300: return((lbot+1)->val);
301: }
302:
303: lispval
304: Lmfunction()
305: {
306: register lispval handy;
307: chkarg(2,"mfunction");
308: handy = (newfunct()); /* get a new function cell */
309: handy->bcd.start = (lispval (*)())((lbot)->val); /* insert entry point */
310: handy->bcd.discipline = ((lbot+1)->val); /* insert discipline */
311: return(handy);
312: }
313:
314: /** Lreplace ************************************************************/
315: /* */
316: /* Destructively modifies almost any kind of data. */
317:
318: lispval
319: Lreplace()
320: {
321: register lispval a1, a2;
322: register int t;
323: chkarg(2,"replace");
324:
325: if((t = TYPE(a1 = (lbot)->val)) != TYPE(a2 = np[-1].val))
326: error("REPLACE ARGS MUST BE SAME TYPE",FALSE);
327:
328: switch( t )
329: {
330:
331: case VALUE: a1->l = a2->l;
332: return( a1 );
333:
334: case INT: a1->i = a2->i;
335: return( a1 );
336:
337:
338: case ARRAY: a1->ar.data = a2->ar.data;
339: a1->ar.accfun = a2->ar.accfun;
340: a1->ar.length = a2->ar.length;
341: a1->ar.delta = a2->ar.delta;
342: return( a1 );
343:
344: case DOUB: a1->r = a2->r;
345: return( a1 );
346:
347: case SDOT:
348: case DTPR: a1->d.car = a2->d.car;
349: a1->d.cdr = a2->d.cdr;
350: return( a1 );
351: case BCD: a1->bcd.start = a2->bcd.start;
352: a1->bcd.discipline = a2->bcd.discipline;
353: return( a1 );
354: default:
355: errorh1(Vermisc,"Replace: cannot handle the type of this arg",
356: nil,FALSE,0,a1);
357: }
358: /* NOTREACHED */
359: }
360:
361: /* Lvaluep */
362:
363: lispval
364: Lvaluep()
365: {
366: chkarg(1,"valuep");
367: if( TYPE(lbot->val) == VALUE ) return(tatom); else return(nil);
368: }
369:
370: CNTTYP() { return; /* HI! COUNT ONE TYPE CALL! */ }
371:
372: lispval
373: Lod()
374: {
375: int i;
376: chkarg(2,"od");
377:
378: while( TYPE(np[-1].val) != INT )
379: np[-1].val = error("2nd ARG TO OD MUST BE INTEGER",TRUE);
380:
381: for( i = 0; i < np->val->i; ++i )
382: printf(copval(odform,CNIL)->a.pname,((int *)(np[-2].val))[i]);
383:
384: dmpport(poport);
385: return(nil);
386: }
387: lispval
388: Lfake()
389: {
390: chkarg(1,"fake");
391:
392: if( TYPE(lbot->val) != INT )
393: error("ARG TO FAKE MUST BE INTEGER",TRUE);
394:
395: return((lispval)(lbot->val->i));
396: }
397:
398: /* this used to be Lwhat, but was changed to Lmaknum for maclisp
399: compatiblity
400: */
401: lispval
402: Lmaknum()
403: {
404: chkarg(1,"maknum");
405: return(inewint((int)(lbot->val)));
406: }
407: lispval
408: Lderef()
409: {
410: chkarg(1,"deref");
411:
412: if( TYPE(lbot->val) != INT )
413: error("arg to deref must be integer",TRUE);
414:
415: return(inewint(*(int *)(lbot->val->i)));
416: }
417:
418: lispval
419: Lpname()
420: {
421: chkarg(1,"pname");
422: if(TYPE(lbot->val) != ATOM)
423: error("ARG TO PNAME MUST BE AN ATOM",FALSE);
424: return((lispval)(lbot->val->a.pname));
425: }
426:
427: lispval
428: Larayref()
429: {
430: chkarg(2,"arrayref");
431: if(TYPE((lbot)->val) != ARRAY)
432: error("FIRST ARG TO ARRAYREF MUST BE ARRAY",FALSE);
433: vtemp = (lbot + 1)->val;
434: chek: while(TYPE(vtemp) != INT)
435: vtemp = error("SECOND ARG TO ARRAYREF MUST BE INTEGER",TRUE);
436: if( vtemp->i < 0 )
437: {
438: vtemp = error("NEGATIVE ARRAY OFFSET",TRUE);
439: goto chek;
440: }
441: if( vtemp->i >= (np-2)->val->ar.length->i )
442: {
443: vtemp = error("ARRAY OFFSET TOO LARGE",TRUE);
444: goto chek;
445: }
446: vtemp = (lispval)((np-2)->val->ar.data + ((np-2)->val->ar.delta->i)*(vtemp->i));
447: /* compute address of desired item */
448: return(vtemp);
449:
450: }
451:
452: lispval
453: Lptr()
454: {
455: chkarg(1,"ptr");
456: return(inewval(lbot->val));
457: }
458:
459: lispval
460: Llctrace()
461: {
462: chkarg(1,"lctrace");
463: lctrace = (int)(lbot->val->a.clb);
464: return((lispval)lctrace);
465: }
466:
467: lispval
468: Lslevel()
469: {
470: return(inewint(np-orgnp-2));
471: }
472:
473: lispval
474: Lsimpld()
475: {
476: register lispval pt;
477: register char *cpt = strbuf;
478:
479: chkarg(1,"simpld");
480:
481: for(atmlen=1, pt=np->val; NOTNIL(pt); ++atmlen, pt = pt->d.cdr);
482:
483: if( atmlen > STRBLEN )
484: {
485: error("LCODE WAS TOO LONG",TRUE);
486: return((lispval)inewstr(""));
487: }
488:
489: for(pt=np->val; NOTNIL(pt); pt = pt->d.cdr) *(cpt++) = pt->d.car->i;
490: *cpt = 0;
491:
492: return((lispval)newstr(1));
493: }
494:
495:
496: /* Lopval *************************************************************/
497: /* */
498: /* Routine which allows system registers and options to be examined */
499: /* and modified. Calls copval, the routine which is called by c code */
500: /* to do the same thing from inside the system. */
501:
502: lispval
503: Lopval()
504: {
505: lispval quant;
506:
507: if( lbot == np )
508: return(error("bad call to opval",TRUE));
509: quant = lbot->val; /* get name of sys variable */
510: while( TYPE(quant) != ATOM )
511: quant = error("first arg to opval must be an atom",TRUE);
512:
513: if(np > lbot+1) vtemp = (lbot+1)->val ;
514: else vtemp = CNIL;
515: return(copval(quant,vtemp));
516: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.