![[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] / 42BSD / ucb / lisp / franz|
Return to lamr.c CVS log | Up to [CSRG BSD Unix] / 42BSD / ucb / lisp / franz |
1.1 root 1: #ifndef lint
2: static char *rcsid =
3: "$Header: lamr.c 1.2 83/06/04 02:15:48 sklower 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: Lgetentry()
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 (*)())((np-5)->val); /* insert entry point */
310: handy->bcd.discipline = ((np-4)->val); /* insert discipline */
311: #ifdef ROWAN
312: handy->language = (np-3)->val; /* insert language */
313: handy->params = ((np-2)->val); /* insert parameters */
314: handy->loctab = ((np-1)->val); /* insert local table */
315: #endif
316: return(handy);
317: }
318:
319: /** Lreplace ************************************************************/
320: /* */
321: /* Destructively modifies almost any kind of data. */
322:
323: lispval
324: Lreplace()
325: {
326: register lispval a1, a2;
327: register int t;
328: chkarg(2,"replace");
329:
330: if((t = TYPE(a1 = (lbot)->val)) != TYPE(a2 = np[-1].val))
331: error("REPLACE ARGS MUST BE SAME TYPE",FALSE);
332:
333: switch( t )
334: {
335:
336: case VALUE: a1->l = a2->l;
337: return( a1 );
338:
339: case INT: a1->i = a2->i;
340: return( a1 );
341:
342:
343: case ARRAY: a1->ar.data = a2->ar.data;
344: a1->ar.accfun = a2->ar.accfun;
345: a1->ar.length = a2->ar.length;
346: a1->ar.delta = a2->ar.delta;
347: return( a1 );
348:
349: case DOUB: a1->r = a2->r;
350: return( a1 );
351:
352: case SDOT:
353: case DTPR: a1->d.car = a2->d.car;
354: a1->d.cdr = a2->d.cdr;
355: return( a1 );
356: case BCD: a1->bcd.start = a2->bcd.start;
357: a1->bcd.discipline = a2->bcd.discipline;
358: return( a1 );
359: default:
360: errorh1(Vermisc,"Replace: cannot handle the type of this arg",
361: nil,FALSE,0,a1);
362: }
363: /* NOTREACHED */
364: }
365:
366: /* Lvaluep */
367:
368: lispval
369: Lvaluep()
370: {
371: chkarg(1,"valuep");
372: if( TYPE(lbot->val) == VALUE ) return(tatom); else return(nil);
373: }
374:
375: CNTTYP() { return; /* HI! COUNT ONE TYPE CALL! */ }
376:
377: lispval
378: Lod()
379: {
380: int i;
381: chkarg(2,"od");
382:
383: while( TYPE(np[-1].val) != INT )
384: np[-1].val = error("2nd ARG TO OD MUST BE INTEGER",TRUE);
385:
386: for( i = 0; i < np->val->i; ++i )
387: printf(copval(odform,CNIL)->a.pname,((int *)(np[-2].val))[i]);
388:
389: dmpport(poport);
390: return(nil);
391: }
392: lispval
393: Lfake()
394: {
395: chkarg(1,"fake");
396:
397: if( TYPE(lbot->val) != INT )
398: error("ARG TO FAKE MUST BE INTEGER",TRUE);
399:
400: return((lispval)(lbot->val->i));
401: }
402:
403: /* this used to be Lwhat, but was changed to Lmaknum for maclisp
404: compatiblity
405: */
406: lispval
407: Lmaknum()
408: {
409: chkarg(1,"maknum");
410: return(inewint((int)(lbot->val)));
411: }
412: lispval
413: Lderef()
414: {
415: chkarg(1,"deref");
416:
417: if( TYPE(lbot->val) != INT )
418: error("arg to deref must be integer",TRUE);
419:
420: return(inewint(*(int *)(lbot->val->i)));
421: }
422:
423: lispval
424: Lpname()
425: {
426: chkarg(1,"pname");
427: if(TYPE(lbot->val) != ATOM)
428: error("ARG TO PNAME MUST BE AN ATOM",FALSE);
429: return((lispval)(lbot->val->a.pname));
430: }
431:
432: lispval
433: Larrayref()
434: {
435: chkarg(2,"arrayref");
436: if(TYPE((lbot)->val) != ARRAY)
437: error("FIRST ARG TO ARRAYREF MUST BE ARRAY",FALSE);
438: vtemp = (lbot + 1)->val;
439: chek: while(TYPE(vtemp) != INT)
440: vtemp = error("SECOND ARG TO ARRAYREF MUST BE INTEGER",TRUE);
441: if( vtemp->i < 0 )
442: {
443: vtemp = error("NEGATIVE ARRAY OFFSET",TRUE);
444: goto chek;
445: }
446: if( vtemp->i >= (np-2)->val->ar.length->i )
447: {
448: vtemp = error("ARRAY OFFSET TOO LARGE",TRUE);
449: goto chek;
450: }
451: vtemp = (lispval)((np-2)->val->ar.data + ((np-2)->val->ar.delta->i)*(vtemp->i));
452: /* compute address of desired item */
453: return(vtemp);
454:
455: }
456:
457: lispval
458: Lptr()
459: {
460: chkarg(1,"ptr");
461: return(inewval(lbot->val));
462: }
463:
464: lispval
465: Llctrace()
466: {
467: chkarg(1,"lctrace");
468: lctrace = (int)(lbot->val->a.clb);
469: return((lispval)lctrace);
470: }
471:
472: lispval
473: Lslevel()
474: {
475: return(inewint(np-orgnp-2));
476: }
477:
478: lispval
479: Lsimpld()
480: {
481: register lispval pt;
482: register char *cpt = strbuf;
483:
484: chkarg(1,"simpld");
485:
486: for(atmlen=1, pt=np->val; NOTNIL(pt); ++atmlen, pt = pt->d.cdr);
487:
488: if( atmlen > STRBLEN )
489: {
490: error("LCODE WAS TOO LONG",TRUE);
491: return((lispval)inewstr(""));
492: }
493:
494: for(pt=np->val; NOTNIL(pt); pt = pt->d.cdr) *(cpt++) = pt->d.car->i;
495: *cpt = 0;
496:
497: return((lispval)newstr(1));
498: }
499:
500:
501: /* Lopval *************************************************************/
502: /* */
503: /* Routine which allows system registers and options to be examined */
504: /* and modified. Calls copval, the routine which is called by c code */
505: /* to do the same thing from inside the system. */
506:
507: lispval
508: Lopval()
509: {
510: lispval quant;
511:
512: if( lbot == np )
513: return(error("bad call to opval",TRUE));
514: quant = lbot->val; /* get name of sys variable */
515: while( TYPE(quant) != ATOM )
516: quant = error("first arg to opval must be an atom",TRUE);
517:
518: if(np > lbot+1) vtemp = (lbot+1)->val ;
519: else vtemp = CNIL;
520: return(copval(quant,vtemp));
521: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.