![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to lam7.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 lam7.c CVS log | Up to [CSRG BSD Unix] / 40BSD / cmd / lisp |
1.1 root 1: static char *sccsid = "@(#)lam7.c 34.2 11/7/80";
2:
3: #include "global.h"
4:
5: lispval
6: Lfork() {
7: register lispval temp;
8: int pid;
9:
10: chkarg(0,"fork");
11: if ((pid=fork())) {
12: temp = newint();
13: temp->i = pid;
14: return(temp);
15: } else
16: return(nil);
17: }
18:
19: lispval
20: Lwait()
21: {
22: register lispval ret, temp;
23: int status = -1, pid;
24: snpand(2);
25:
26:
27: chkarg(0,"wait");
28: pid = wait(&status);
29: ret = newdot();
30: protect(ret);
31: temp = newint();
32: temp->i = pid;
33: ret->d.car = temp;
34: temp = newint();
35: temp->i = status;
36: ret->d.cdr = temp;
37: return(ret);
38: }
39:
40: lispval
41: Lpipe()
42: {
43: register lispval ret, temp;
44: int pipes[2];
45: snpand(2);
46:
47: chkarg(0,"pipe");
48: pipes[0] = -1;
49: pipes[1] = -1;
50: pipe(pipes);
51: ret = newdot();
52: protect(ret);
53: temp = newint();
54: temp->i = pipes[0];
55: ret->d.car = temp;
56: temp = newint();
57: temp->i = pipes[1];
58: ret->d.cdr = temp;
59: return(ret);
60: }
61:
62: lispval
63: Lfdopen()
64: {
65: register lispval fd, type;
66: FILE *ptr;
67:
68: chkarg(2,"fdopen");
69: type = (np-1)->val;
70: fd = lbot->val;
71: if( TYPE(fd)!=INT )
72: return(nil);
73: if ( (ptr=fdopen((int)fd->i, (char *)type->a.pname))==NULL)
74: return(nil);
75: return(P(ptr));
76: }
77:
78: lispval
79: Lexece()
80: {
81: lispval fname, arglist, envlist, temp;
82: char *args[100], *envs[100], estrs[1024];
83: char *p, *cp, **sp;
84: snpand(0);
85:
86: switch(np-lbot) {
87: case 0:
88: protect(nil);
89: case 1:
90: protect(nil);
91: case 2:
92: protect(nil);
93: case 3:
94: break;
95: default:
96: argerr("exece");
97: }
98: envlist = (--np)->val;
99: arglist = (--np)->val;
100: fname = (--np)->val;
101: while (TYPE(fname)!=ATOM)
102: fname = error("exece: non atom function name",TRUE);
103: while (TYPE(arglist)!=DTPR && arglist!=nil)
104: arglist = error("exece: non list arglist",TRUE);
105: for (sp=args; arglist!=nil; arglist=arglist->d.cdr) {
106: temp = arglist->d.car;
107: if (TYPE(temp)!=ATOM)
108: error("exece: non atom argument seen",FALSE);
109: *sp++ = temp->a.pname;
110: }
111: *sp = 0;
112: if (TYPE(envlist)!=DTPR && envlist!=nil)
113: return(nil);
114: for (sp=envs,cp=estrs; envlist!=nil; envlist=envlist->d.cdr) {
115: temp = envlist->d.car;
116: if (TYPE(temp)!=DTPR || TYPE(temp->d.car)!=ATOM
117: || TYPE(temp->d.cdr)!=ATOM)
118: error("exece: Bad enviroment list",FALSE);
119: *sp++ = cp;
120: for (p=temp->d.car->a.pname; (*cp++ = *p++);) ;
121: *(cp-1) = '=';
122: for (p=temp->d.cdr->a.pname; (*cp++ = *p++);) ;
123: }
124: *sp = 0;
125:
126: return(inewint(execve(fname->a.pname, args, envs)));
127: }
128:
129: int gensymcounter = 0; /* should really be in data.c */
130:
131: lispval
132: Lgensym()
133: {
134: lispval arg;
135: char leader;
136: snpand(0);
137:
138: if(lbot-np==0)protect(nil);
139: arg = lbot->val;
140: leader = 'g';
141: if (arg != nil && TYPE(arg)==ATOM)
142: leader = arg->a.pname[0];
143: sprintf(strbuf, "%c%05d", leader, gensymcounter++);
144: atmlen = 7;
145: return((lispval)newatom());
146: }
147: extern struct types {
148: char *next_free;
149: int space_left,
150: space,
151: type,
152: type_len; /* note type_len is in units of int */
153: lispval *items,
154: *pages,
155: *type_name;
156: struct heads
157: *first;
158: } atom_str ;
159:
160: lispval
161: Lremprop()
162: {
163: register struct argent *argp;
164: register lispval pptr, ind, opptr;
165: register struct argent *lbot, *np;
166: lispval atm;
167: int disemp = FALSE;
168:
169: chkarg(2,"remprop");
170: argp = lbot;
171: ind = argp[1].val;
172: atm = argp->val;
173: switch (TYPE(atm)) {
174: case DTPR:
175: pptr = atm->d.cdr;
176: disemp = TRUE;
177: break;
178: case ATOM:
179: if((lispval)atm==nil)
180: pptr = nilplist;
181: else
182: pptr = atm->a.plist;
183: break;
184: default:
185: errorh(Vermisc, "remprop: Illegal first argument :",
186: nil, FALSE, 0, atm);
187: }
188: opptr = nil;
189: if (pptr==nil)
190: return(nil);
191: while(TRUE) {
192: if (TYPE(pptr->d.cdr)!=DTPR)
193: errorh(Vermisc, "remprop: Bad property list",
194: nil, FALSE, 0,atm);
195: if (pptr->d.car == ind) {
196: if( opptr != nil)
197: opptr->d.cdr = pptr->d.cdr->d.cdr;
198: else if(disemp)
199: atm->d.cdr = pptr->d.cdr->d.cdr;
200: else if(atm==nil)
201: nilplist = pptr->d.cdr->d.cdr;
202: else
203: atm->a.plist = pptr->d.cdr->d.cdr;
204: return(pptr->d.cdr);
205: }
206: if ((pptr->d.cdr)->d.cdr == nil) return(nil);
207: opptr = pptr->d.cdr;
208: pptr = (pptr->d.cdr)->d.cdr;
209: }
210: }
211:
212: lispval
213: Lbcdad()
214: {
215: lispval ret, temp;
216:
217: chkarg(1,"bcdad");
218: temp = lbot->val;
219: if (TYPE(temp)!=ATOM)
220: error("ONLY ATOMS HAVE FUNCTION BINDINGS", FALSE);
221: temp = temp->a.fnbnd;
222: if (TYPE(temp)!=BCD)
223: return(nil);
224: ret = newint();
225: ret->i = (int)temp;
226: return(ret);
227: }
228:
229: lispval
230: Lstringp()
231: {
232: chkarg(1,"stringp");
233: if (TYPE(lbot->val)==STRNG)
234: return(tatom);
235: return(nil);
236: }
237:
238: lispval
239: Lsymbolp()
240: {
241: chkarg(1,"symbolp");
242: if (TYPE(lbot->val)==ATOM)
243: return(tatom);
244: return(nil);
245: }
246:
247: lispval
248: Lrematom()
249: {
250: register lispval temp;
251:
252: chkarg(1,"rematom");
253: temp = lbot->val;
254: if (TYPE(temp)!=ATOM)
255: return(nil);
256: temp->a.fnbnd = nil;
257: temp->a.pname = (char *)CNIL;
258: temp->a.plist = nil;
259: (atom_items->i)--;
260: (atom_str.space_left)++;
261: temp->a.clb=(lispval)atom_str.next_free;
262: atom_str.next_free=(char *) temp;
263: return(tatom);
264: }
265:
266: #define QUTMASK 0200
267: #define VNUM 0000
268:
269: lispval
270: Lprname()
271: {
272: lispval a, ret;
273: register lispval work, prev;
274: char *front, *temp; int clean;
275: char ctemp[100];
276: extern char *ctable;
277: snpand(2);
278:
279: chkarg(1,"prname");
280: a = lbot->val;
281: switch (TYPE(a)) {
282: case INT:
283: sprintf(ctemp,"%d",a->i);
284: break;
285:
286: case DOUB:
287: sprintf(ctemp,"%f",a->r);
288: break;
289:
290: case ATOM:
291: temp = front = a->a.pname;
292: clean = *temp;
293: if (*temp == '-') temp++;
294: clean = clean && (ctable[*temp] != VNUM);
295: while (clean && *temp)
296: clean = (!(ctable[*temp++] & QUTMASK));
297: if (clean)
298: strcpyn(ctemp, front, 99);
299: else
300: sprintf(ctemp,"\"%s\"",front);
301: break;
302:
303: default:
304: error("prname does not support this type", FALSE);
305: }
306: temp = ctemp;
307: protect(ret = prev = newdot());
308: while (*temp) {
309: prev->d.cdr = work = newdot();
310: strbuf[0] = *temp++;
311: strbuf[1] = 0;
312: work->d.car = getatom();
313: work->d.cdr = nil;
314: prev = work;
315: }
316: return(ret->d.cdr);
317: }
318: Lexit()
319: {
320: register lispval handy;
321: if(np-lbot==0) exit(0);
322: handy = lbot->val;
323: if(TYPE(handy)==INT)
324: exit(handy->i);
325: exit(-1);
326: }
327: lispval
328: Iimplode(unintern)
329: {
330: register lispval handy, work;
331: register char *cp = strbuf;
332: extern int atmlen; /* used by newatom and getatom */
333:
334: chkarg(1,"implode");
335: for(handy = lbot->val; handy!=nil; handy = handy->d.cdr)
336: {
337: work = handy->d.car;
338: if(cp >= endstrb)
339: errorh(Vermisc,"maknam/impode argument exceeds buffer",nil,FALSE,43,lbot->val);
340: again:
341: switch(TYPE(work))
342: {
343: case ATOM:
344: *cp++ = work->a.pname[0];
345: break;
346: case SDOT:
347: case INT:
348: *cp++ = work->i;
349: break;
350: case STRNG:
351: *cp++ = * (char *) work;
352: break;
353: default:
354: work = errorh(Vermisc,"implode/maknam: Illegal type for this arg:",nil,FALSE,44,work);
355: goto again;
356: }
357: }
358: *cp = 0;
359: if(unintern) return((lispval)newatom());
360: else return((lispval) getatom());
361: }
362:
363: lispval
364: Lmaknam()
365: {
366: return(Iimplode(TRUE)); /* unintern result */
367: }
368:
369: lispval
370: Limplode()
371: {
372: return(Iimplode(FALSE)); /* intern result */
373: }
374:
375: lispval
376: Lintern()
377: {
378: register int hash;
379: register lispval handy,atpr;
380: register char *name;
381:
382:
383: chkarg(1,"intern");
384: if(TYPE(handy=lbot->val) != ATOM)
385: errorh(Vermisc,"non atom to intern ",nil,FALSE,0,handy);
386: /* compute hash of pname of arg */
387: hash = hashfcn(handy->a.pname);
388:
389: /* search for atom with same pname on hash list */
390:
391: atpr = (lispval) hasht[hash];
392: for(atpr = (lispval) hasht[hash]
393: ; atpr != CNIL
394: ; atpr = (lispval)atpr->a.hshlnk)
395: {
396: if(strcmp(atpr->a.pname,handy->a.pname) == 0) return(atpr);
397: }
398:
399: /* not there yet, put the given one on */
400:
401: handy->a.hshlnk = hasht[hash];
402: hasht[hash] = (struct atom *)handy;
403: return(handy);
404: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.