![[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] / 43BSDReno / pgrm / lisp / franz|
Return to lam7.c CVS log | Up to [CSRG BSD Unix] / 43BSDReno / pgrm / lisp / franz |
1.1 root 1: #ifndef lint
2: static char *rcsid =
3: "$Header: lam7.c,v 1.9 87/12/14 18:48:02 sklower Exp $";
4: #endif
5:
6: /* -[Fri Aug 5 12:51:31 1983 by jkf]-
7: * lam7.c $Locker: $
8: * lambda functions
9: *
10: * (c) copyright 1982, Regents of the University of California
11: */
12:
13: #include "global.h"
14: #include <signal.h>
15:
16:
17: lispval
18: Lfork() {
19: int pid;
20:
21: chkarg(0,"fork");
22: if ((pid=fork())) {
23: return(inewint(pid));
24: } else
25: return(nil);
26: }
27:
28: lispval
29: Lwait()
30: {
31: register lispval ret, temp;
32: int status = -1, pid;
33: Savestack(2);
34:
35:
36: chkarg(0,"wait");
37: pid = wait(&status);
38: ret = newdot();
39: protect(ret);
40: temp = inewint(pid);
41: ret->d.car = temp;
42: temp = inewint(status);
43: ret->d.cdr = temp;
44: Restorestack();
45: return(ret);
46: }
47:
48: lispval
49: Lpipe()
50: {
51: register lispval ret, temp;
52: int pipes[2];
53: Savestack(2);
54:
55: chkarg(0,"pipe");
56: pipes[0] = -1;
57: pipes[1] = -1;
58: pipe(pipes);
59: ret = newdot();
60: protect(ret);
61: temp = inewint(pipes[0]);
62: ret->d.car = temp;
63: temp = inewint(pipes[1]);
64: ret->d.cdr = temp;
65: Restorestack();
66: return(ret);
67: }
68:
69: lispval
70: Lfdopen()
71: {
72: register lispval fd, type;
73: FILE *ptr;
74:
75: chkarg(2,"fdopen");
76: type = (np-1)->val;
77: fd = lbot->val;
78: if( TYPE(fd)!=INT )
79: return(nil);
80: if ( (ptr=fdopen((int)fd->i, (char *)type->a.pname))==NULL)
81: return(nil);
82: return(P(ptr));
83: }
84:
85: lispval
86: Lexece()
87: {
88: lispval fname, arglist, envlist, temp;
89: char *args[100], *envs[100], estrs[1024];
90: char *p, *cp, **argsp;
91:
92: fname = nil;
93: arglist = nil;
94: envlist = nil;
95:
96: switch(np-lbot) {
97: case 3: envlist = lbot[2].val;
98: case 2: arglist = lbot[1].val;
99: case 1: fname = lbot[0].val;
100: case 0: break;
101: default:
102: argerr("exece");
103: }
104:
105: while (TYPE(fname)!=ATOM)
106: fname = error("exece: non atom function name",TRUE);
107: while (TYPE(arglist)!=DTPR && arglist!=nil)
108: arglist = error("exece: non list arglist",TRUE);
109: for (argsp=args; arglist!=nil; arglist=arglist->d.cdr) {
110: temp = arglist->d.car;
111: if (TYPE(temp)!=ATOM)
112: error("exece: non atom argument seen",FALSE);
113: *argsp++ = temp->a.pname;
114: }
115: *argsp = 0;
116: if (TYPE(envlist)!=DTPR && envlist!=nil)
117: return(nil);
118: for (argsp=envs,cp=estrs; envlist!=nil; envlist=envlist->d.cdr) {
119: temp = envlist->d.car;
120: if (TYPE(temp)!=DTPR || TYPE(temp->d.car)!=ATOM
121: || TYPE(temp->d.cdr)!=ATOM)
122: error("exece: Bad enviroment list",FALSE);
123: *argsp++ = cp;
124: for (p=temp->d.car->a.pname; (*cp++ = *p++);) ;
125: *(cp-1) = '=';
126: for (p=temp->d.cdr->a.pname; (*cp++ = *p++);) ;
127: }
128: *argsp = 0;
129:
130: return(inewint(execve(fname->a.pname, args, envs)));
131: }
132:
133: /* Lprocess -
134: * C code to implement the *process function
135: * call:
136: * (*process 'st_command ['s_readp ['s_writep]])
137: * where st_command is the command to execute
138: * s_readp is non nil if you want a port to read from returned
139: * s_writep is non nil if you want a port to write to returned
140: * both flags default to nil
141: * *process returns
142: * the exit status of the process if s_readp and s_writep not given
143: * (in this case the parent waits for the child to finish)
144: * a list of (readport writeport childpid) if one of s_readp or s_writep
145: * is given. If only s_readp is non nil, then writeport will be nil,
146: * If only s_writep is non nil, then readport will be nil
147: */
148:
149: lispval
150: Lprocess()
151: {
152: int wflag , childsi , childso , child;
153: lispval handy;
154: char *command, *p;
155: int writep, readp;
156: int itemp;
157: int (*handler)(), (*signal())();
158: FILE *bufs[2],*obufs[2], *fpipe();
159: Savestack(0);
160:
161: writep = readp = FALSE;
162: wflag = TRUE;
163:
164: switch(np-lbot) {
165: case 3: if(lbot[2].val != nil) writep = TRUE;
166: case 2: if(lbot[1].val != nil) readp = TRUE;
167: wflag = 0;
168: case 1: command = (char *) verify(lbot[0].val,
169: "*process: non atom first arg");
170: break;
171: default:
172: argerr("*process");
173: }
174:
175: childsi = 0;
176: childso = 1;
177:
178: /* if there will be communication between the processes,
179: * it will be through these pipes:
180: * parent -> bufs[1] -> bufs[0] -> child if writep
181: * parent <- obufs[0] <- obufs[1] <- parent if readp
182: */
183: if(writep) {
184: fpipe(bufs);
185: childsi = fileno(bufs[0]);
186: }
187:
188: if(readp) {
189: fpipe(obufs);
190: childso = fileno(obufs[1]);
191: }
192:
193: handler = signal(SIGINT,SIG_IGN);
194: if((child = vfork()) == 0 ) {
195: /* if we will wait for the child to finish
196: * and if the process had ignored interrupts before
197: * we were called, then leave them ignored, else
198: * set it back the the default (death)
199: */
200: if(wflag && handler != SIG_IGN)
201: signal(2,SIG_DFL);
202:
203: if(writep) {
204: close(0);
205: dup(childsi);
206: }
207: if (readp) {
208: close(1);
209: dup(childso);
210: }
211: if ((p = (char *)getenv("SHELL")) != (char *)0) {
212: execlp(p , p, "-c",command,0);
213: _exit(-1); /* if exec fails, signal problems*/
214: } else {
215: execlp("csh", "csh", "-c",command,0);
216: execlp("sh", "sh", "-c",command,0);
217: _exit(-1); /* if exec fails, signal problems*/
218: }
219: }
220:
221: /* close the duplicated file descriptors
222: * e.g. if writep is true then we've created two desriptors,
223: * bufs[0] and bufs[1], we will write to bufs[1] and the
224: * child (who has a copy of our bufs[0]) will read from bufs[0]
225: * We (the parent) close bufs[0] since we will not be reading
226: * from it.
227: */
228: if(writep) fclose(bufs[0]);
229: if(readp) fclose(obufs[1]);
230:
231: if(wflag && child!= -1) {
232: int status=0;
233: /* we await the death of the child */
234: while(wait(&status)!=child) {}
235: /* the child has died */
236: signal(2,handler); /* restore the interrupt handler */
237: itemp = status >> 8;
238: Restorestack();
239: return(inewint(itemp)); /* return its status */
240: }
241: /* we are not waiting for the childs death
242: * build a list containing the write and read ports
243: */
244: protect(handy = newdot());
245: handy->d.cdr = newdot();
246: handy->d.cdr->d.cdr = newdot();
247: if(readp) {
248: handy->d.car = P(obufs[0]);
249: ioname[PN(obufs[0])] = (lispval) inewstr((char *) "from-process");
250: }
251: if(writep) {
252: handy->d.cdr->d.car = P(bufs[1]);
253: ioname[PN(bufs[1])] = (lispval) inewstr((char *) "to-process");
254: }
255: handy->d.cdr->d.cdr->d.car = (lispval) inewint(child);
256: signal(SIGINT,handler);
257: Restorestack();
258: return(handy);
259: }
260:
261: extern int gensymcounter;
262:
263: lispval
264: Lgensym()
265: {
266: lispval arg;
267: char leader;
268:
269: switch(np-lbot)
270: {
271: case 0: arg = nil;
272: break;
273: case 1: arg = lbot->val;
274: break;
275: default: argerr("gensym");
276: }
277: leader = 'g';
278: if (arg != nil && TYPE(arg)==ATOM)
279: leader = arg->a.pname[0];
280: sprintf(strbuf, "%c%05d", leader, gensymcounter++);
281: atmlen = 7;
282: return((lispval)newatom(0));
283: }
284:
285: extern struct types {
286: char *next_free;
287: int space_left,
288: space,
289: type,
290: type_len; /* note type_len is in units of int */
291: lispval *items,
292: *pages,
293: *type_name;
294: struct heads
295: *first;
296: } atom_str ;
297:
298: lispval
299: Lremprop()
300: {
301: register struct argent *argp;
302: register lispval pptr, ind, opptr;
303: lispval atm;
304: int disemp = FALSE;
305:
306: chkarg(2,"remprop");
307: argp = lbot;
308: ind = argp[1].val;
309: atm = argp->val;
310: switch (TYPE(atm)) {
311: case DTPR:
312: pptr = atm->d.cdr;
313: disemp = TRUE;
314: break;
315: case ATOM:
316: if((lispval)atm==nil)
317: pptr = nilplist;
318: else
319: pptr = atm->a.plist;
320: break;
321: default:
322: errorh1(Vermisc, "remprop: Illegal first argument :",
323: nil, FALSE, 0, atm);
324: }
325: opptr = nil;
326: if (pptr==nil)
327: return(nil);
328: while(TRUE) {
329: if (TYPE(pptr->d.cdr)!=DTPR)
330: errorh1(Vermisc, "remprop: Bad property list",
331: nil, FALSE, 0,atm);
332: if (pptr->d.car == ind) {
333: if( opptr != nil)
334: opptr->d.cdr = pptr->d.cdr->d.cdr;
335: else if(disemp)
336: atm->d.cdr = pptr->d.cdr->d.cdr;
337: else if(atm==nil)
338: nilplist = pptr->d.cdr->d.cdr;
339: else
340: atm->a.plist = pptr->d.cdr->d.cdr;
341: return(pptr->d.cdr);
342: }
343: if ((pptr->d.cdr)->d.cdr == nil) return(nil);
344: opptr = pptr->d.cdr;
345: pptr = (pptr->d.cdr)->d.cdr;
346: }
347: }
348:
349: lispval
350: Lbcdad()
351: {
352: lispval ret, temp;
353:
354: chkarg(1,"bcdad");
355: temp = lbot->val;
356: if (TYPE(temp)!=ATOM)
357: error("ONLY ATOMS HAVE FUNCTION BINDINGS", FALSE);
358: temp = temp->a.fnbnd;
359: if (TYPE(temp)!=BCD)
360: return(nil);
361: ret = newint();
362: ret->i = (int)temp;
363: return(ret);
364: }
365:
366: lispval
367: Lstringp()
368: {
369: chkarg(1,"stringp");
370: if (TYPE(lbot->val)==STRNG)
371: return(tatom);
372: return(nil);
373: }
374:
375: lispval
376: Lsymbolp()
377: {
378: chkarg(1,"symbolp");
379: if (TYPE(lbot->val)==ATOM)
380: return(tatom);
381: return(nil);
382: }
383:
384: lispval
385: Lrematom()
386: {
387: register lispval temp;
388:
389: chkarg(1,"rematom");
390: temp = lbot->val;
391: if (TYPE(temp)!=ATOM)
392: return(nil);
393: temp->a.fnbnd = nil;
394: temp->a.pname = (char *)CNIL;
395: temp->a.plist = nil;
396: (atom_items->i)--;
397: (atom_str.space_left)++;
398: temp->a.clb=(lispval)atom_str.next_free;
399: atom_str.next_free=(char *) temp;
400: return(tatom);
401: }
402:
403: #define QUTMASK 0200
404: #define VNUM 0000
405:
406: lispval
407: Lprname()
408: {
409: lispval a, ret;
410: register lispval work, prev;
411: char *front, *temp; int clean;
412: char ctemp[100];
413: extern unsigned char *ctable;
414: Savestack(2);
415:
416: chkarg(1,"prname");
417: a = lbot->val;
418: switch (TYPE(a)) {
419: case INT:
420: sprintf(ctemp,"%d",a->i);
421: break;
422:
423: case DOUB:
424: sprintf(ctemp,"%f",a->r);
425: break;
426:
427: case ATOM:
428: temp = front = a->a.pname;
429: clean = *temp;
430: if (*temp == '-') temp++;
431: clean = clean && (ctable[*temp] != VNUM);
432: while (clean && *temp)
433: clean = (!(ctable[*temp++] & QUTMASK));
434: if (clean)
435: strncpy(ctemp, front, 99);
436: else
437: sprintf(ctemp,"\"%s\"",front);
438: break;
439:
440: default:
441: error("prname does not support this type", FALSE);
442: }
443: temp = ctemp;
444: protect(ret = prev = newdot());
445: while (*temp) {
446: prev->d.cdr = work = newdot();
447: strbuf[0] = *temp++;
448: strbuf[1] = 0;
449: work->d.car = getatom(FALSE);
450: work->d.cdr = nil;
451: prev = work;
452: }
453: Restorestack();
454: return(ret->d.cdr);
455: }
456:
457: lispval
458: Lexit()
459: {
460: register lispval handy;
461: if(np-lbot==0) franzexit(0);
462: handy = lbot->val;
463: if(TYPE(handy)==INT)
464: franzexit((int) handy->i);
465: franzexit(-1);
466: }
467: lispval
468: Iimplode(unintern)
469: {
470: register lispval handy, work;
471: register char *cp = strbuf;
472: extern int atmlen; /* used by newatom and getatom */
473: extern char *atomtoolong();
474:
475: chkarg(1,"implode");
476: for(handy = lbot->val; handy!=nil; handy = handy->d.cdr)
477: {
478: work = handy->d.car;
479: if(cp >= endstrb)
480: cp = atomtoolong(cp);
481: again:
482: switch(TYPE(work))
483: {
484: case ATOM:
485: *cp++ = work->a.pname[0];
486: break;
487: case SDOT:
488: *cp++ = work->s.I;
489: break;
490: case INT:
491: *cp++ = work->i;
492: break;
493: case STRNG:
494: *cp++ = * (char *) work;
495: break;
496: default:
497: work = errorh1(Vermisc,"implode/maknam: Illegal type for this arg:",nil,FALSE,44,work);
498: goto again;
499: }
500: }
501: *cp = 0;
502: if(unintern) return((lispval)newatom(FALSE));
503: else return((lispval) getatom(FALSE));
504: }
505:
506: lispval
507: Lmaknam()
508: {
509: return(Iimplode(TRUE)); /* unintern result */
510: }
511:
512: lispval
513: Limplode()
514: {
515: return(Iimplode(FALSE)); /* intern result */
516: }
517:
518: lispval
519: Lntern()
520: {
521: register int hash;
522: register lispval handy,atpr;
523:
524:
525: chkarg(1,"intern");
526: if(TYPE(handy=lbot->val) != ATOM)
527: errorh1(Vermisc,"non atom to intern ",nil,FALSE,0,handy);
528: /* compute hash of pname of arg */
529: hash = hashfcn(handy->a.pname);
530:
531: /* search for atom with same pname on hash list */
532:
533: atpr = (lispval) hasht[hash];
534: for(atpr = (lispval) hasht[hash]
535: ; atpr != CNIL
536: ; atpr = (lispval)atpr->a.hshlnk)
537: {
538: if(strcmp(atpr->a.pname,handy->a.pname) == 0) return(atpr);
539: }
540:
541: /* not there yet, put the given one on */
542:
543: handy->a.hshlnk = hasht[hash];
544: hasht[hash] = (struct atom *)handy;
545: return(handy);
546: }
547:
548: /*** Ibindvars :: lambda bind values to variables
549: called with a list of variables and values.
550: does the special binding and returns a fixnum which represents
551: the value of bnp before the binding
552: Use by compiled progv's.
553: ***/
554: lispval
555: Ibindvars()
556: {
557: register lispval vars,vals,handy;
558: struct nament *oldbnp = bnp;
559:
560: chkarg(2,"int:bindvars");
561:
562: vars = lbot[0].val;
563: vals = lbot[1].val;
564:
565: if(vars == nil) return(inewint(oldbnp));
566:
567: if(TYPE(vars) != DTPR)
568: errorh1(Vermisc,"progv (int:bindvars): bad first argument ", nil,
569: FALSE,0,vars);
570: if((vals != nil) && (TYPE(vals) != DTPR))
571: errorh1(Vermisc,"progv (int:bindvars): bad second argument ",nil,
572: FALSE,0,vals);
573:
574: for( ; vars != nil ; vars = vars->d.cdr , vals=vals->d.cdr)
575: {
576: handy = vars->d.car;
577: if(TYPE(handy) != ATOM)
578: errorh1(Vermisc,"progv (int:bindvars): non symbol argument to bind ",
579: nil,FALSE,0,handy);
580: PUSHDOWN(handy,vals->d.car);
581: }
582: return(inewint(oldbnp));
583: }
584:
585:
586: /*** Iunbindvars :: unbind the variable stacked by Ibindvars
587: called by compiled progv's
588: ***/
589:
590: lispval
591: Iunbindvars()
592: {
593: struct nament *oldbnp;
594:
595: chkarg(1,"int:unbindvars");
596: oldbnp = (struct nament *) (lbot[0].val->i);
597: if((oldbnp < orgbnp) || ( oldbnp > bnp))
598: errorh1(Vermisc,"int:unbindvars: bad bnp value given ",nil,FALSE,0,
599: lbot[0].val);
600: popnames(oldbnp);
601: return(nil);
602: }
603:
604: /*
605: * (time-string ['x_milliseconds])
606: * if given no argument, returns the current time as a string
607: * if given an argument which is a fixnum representing the current time
608: * as a fixnum, it generates a string from that
609: *
610: * the format of the string returned is that defined in the Unix manual
611: * except the trailing newline is removed.
612: *
613: */
614: lispval
615: Ltymestr()
616: {
617: long timevalue;
618: char *retval;
619:
620: switch(np-lbot)
621: {
622: case 0: time(&timevalue);
623: break;
624: case 1: while (TYPE(lbot[0].val) != INT)
625: lbot[0].val =
626: errorh(Vermisc,"time-string: non fixnum argument ",
627: nil,TRUE,0,lbot[0].val);
628: timevalue = lbot[0].val->i;
629: break;
630: default:
631: argerr("time-string");
632: }
633:
634: retval = (char *) ctime(&timevalue);
635: /* remove newline character */
636: retval[strlen(retval)-1] = '\0';
637: return((lispval) inewstr(retval));
638: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.