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