![[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] / 3BSD / cmd / lisp|
Return to lamr.c CVS log | Up to [CSRG BSD Unix] / 3BSD / cmd / lisp |
1.1 root 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:
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.