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