![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to lam5.c CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 43BSD / ucb / lisp / franz|
Return to lam5.c CVS log | Up to [CSRG BSD Unix] / 43BSD / ucb / lisp / franz |
1.1 root 1: #ifndef lint
2: static char *rcsid =
3: "$Header: lam5.c,v 1.7 83/12/09 16:36:12 sklower Exp $";
4: #endif
5:
6: /* -[Fri Aug 5 12:49:06 1983 by jkf]-
7: * lam5.c $Locker: $
8: * lambda functions
9: *
10: * (c) copyright 1982, Regents of the University of California
11: */
12:
13: #include "global.h"
14: #include "chkrtab.h"
15: #include <ctype.h>
16: char *strcpy(), *sprintf();
17:
18: /*===========================================
19: -
20: - explode functions: aexplode , aexplodec, aexploden
21: - The following function partially implement the explode functions for atoms.
22: - The full explode functions are written in lisp and call these for atom args.
23: -
24: -===========================================*/
25:
26: #include "chars.h"
27: lispval
28: Lexpldx(kind,slashify)
29: int kind, slashify; /* kind = 0 => explode to characters
30: = 1 => explode to fixnums (aexploden)
31: slashify = 0 => do not quote bizarre characters
32: = 1 => quote bizarre characters
33: */
34: {
35: int typ, i;
36: char ch, *strb, strbb[BUFSIZ], *alloca(); /* temporary string buffer */
37: register lispval last, handy;
38: extern int uctolc;
39: register char *cp;
40: Savestack(3); /* kludge register save mask */
41: #ifdef SPISFP
42: Keepxs();
43: #endif
44:
45: chkarg(1,"expldx");
46:
47: handy = Vreadtable->a.clb;
48: chkrtab(handy);
49: handy = lbot->val;
50: *strbuf = 0;
51: typ=TYPE(handy); /* we only work for a few types */
52:
53:
54: /* put the characters to return in the string buffer strb */
55:
56: switch(typ) {
57: case STRNG:
58: if(slashify && !Xsdc)
59: errorh1(Vermisc,"Can't explode without string delimiter",nil
60: ,FALSE,0,handy);
61:
62: strb = strbb;
63: if(slashify) *strb++ = Xsdc;
64: /* copy string into buffer, escape only occurances of the
65: double quoting character if in slashify mode
66: */
67: for(cp = (char *) handy; *cp; cp++)
68: {
69: if(slashify &&
70: (*cp == Xsdc || synclass(ctable[*cp])==CESC))
71: *strb++ = Xesc;
72: *strb++ = *cp;
73: }
74: if(slashify) *strb++ = Xsdc;
75: *strb = NULL_CHAR ;
76: strb = strbb;
77: break;
78:
79: case ATOM:
80: strb = handy->a.pname;
81: if(slashify && (strb[0]==0)) {
82: strb = strbb;
83: strbb[0] = Xdqc;
84: strbb[1] = Xdqc;
85: strbb[2] = 0;
86: } else
87: /*common:*/
88: if(slashify != 0)
89: {
90: char *out = strbb;
91: unsigned char code;
92:
93: cp = strb;
94: strb = strbb;
95: code = ctable[(*cp)&0177];
96: switch(synclass(code)) {
97: case CNUM:
98: *out++ = Xesc;
99: break;
100: case CCHAR:
101: if(uctolc && isupper((*cp)&0177)) {
102: *out++ = Xesc;
103: }
104: break;
105: default:
106: switch(code&QUTMASK) {
107: case QWNUNIQ:
108: if (cp[1]==0) *out++ = Xesc;
109: break;
110: case QALWAYS:
111: case QWNFRST:
112: *out++ = Xesc;
113: }
114: }
115: *out++ = *cp++;
116: for(; *cp; cp++)
117: {
118: if(((ctable[*cp]&QUTMASK)==QALWAYS) ||
119: (uctolc && isupper(*cp)))
120: *out++ = Xesc;
121: *out++ = *cp;
122: }
123: *out = 0;
124: }
125: break;
126:
127: case INT:
128: strb = strbb;
129: sprintf(strb, "%d", lbot->val->i);
130: break;
131: case DOUB:
132: strb = strbb;
133: lfltpr(strb, lbot->val->r);
134: break;
135: case SDOT:
136: {
137: struct _iobuf _strbuf;
138: int count;
139: for((handy = lbot->val), count = 12;
140: handy->s.CDR!=(lispval) 0;
141: (handy = handy->s.CDR), count += 12);
142: strb = alloca(count);
143:
144: _strbuf._flag = _IOWRT+_IOSTRG;
145: _strbuf._ptr = strb;
146: _strbuf._cnt = count;
147: pbignum(lbot->val,&_strbuf);
148: putc(0,&_strbuf);
149: break;
150: }
151: default:
152: errorh1(Vermisc,"EXPLODE ARG MUST BE STRING, SYMBOL, FIXNUM, OR FLONUM",nil,FALSE,0,handy);
153: Restorestack();
154: Freexs();
155: return(nil);
156: }
157:
158:
159: if( strb[0] != NULL_CHAR ) /* if there is something to do */
160: {
161: lispval prev;
162:
163: protect(handy = last = newdot());
164: strbuf[1] = NULL_CHAR ; /* set up for getatom */
165: atmlen = 2;
166:
167: for(i=0; ch = strb[i++]; ) {
168: switch(kind) {
169:
170: case 0: strbuf[0] = hash = ch; /* character explode */
171: last->d.car = (lispval) getatom(TRUE); /* look in oblist */
172: break;
173:
174: case 1:
175: last->d.car = inewint(ch);
176: break;
177: }
178:
179: /* advance pointers */
180: prev = last;
181: last->d.cdr = newdot();
182: last = last->d.cdr;
183: }
184:
185: /* end list with a nil pointer */
186: prev->d.cdr = nil;
187: Freexs();
188: Restorestack();
189: return(handy);
190: }
191: Freexs();
192: Restorestack();
193: return(nil); /* return nil if no characters */
194: }
195:
196: /*===========================
197: -
198: - (aexplodec 'atm) returns (a t m)
199: - (aexplodec 234) returns (\2 \3 \4)
200: -===========================*/
201:
202: lispval
203: Lxpldc()
204: { return(Lexpldx(0,0)); }
205:
206:
207: /*===========================
208: -
209: - (aexploden 'abc) returns (65 66 67)
210: - (aexploden 123) returns (49 50 51)
211: -=============================*/
212:
213:
214: lispval
215: Lxpldn()
216: { return(Lexpldx(1,0)); }
217:
218: /*===========================
219: -
220: - (aexplode "123") returns (\\ \1 \2 \3);
221: - (aexplode 123) returns (\1 \2 \3);
222: -=============================*/
223:
224: lispval
225: Lxplda()
226: { return(Lexpldx(0,1)); }
227:
228: /*
229: * (argv) returns how many arguments where on the command line which invoked
230: * lisp; (argv i) returns the i'th argument made into an atom;
231: */
232:
233: lispval
234: Largv()
235: {
236: register lispval handy;
237: extern int Xargc;
238: extern char **Xargv;
239:
240: if(lbot-np==0)handy = nil;
241: else handy = lbot->val;
242:
243: if(TYPE(handy)==INT && handy->i>=0 && handy->i<Xargc) {
244: strcpy(strbuf,Xargv[handy->i]);
245: return(getatom(FALSE));
246: } else {
247: return(inewint(Xargc));
248: }
249: }
250: /*
251: * (chdir <atom>) executes a chdir command
252: * if successful, return t otherwise returns nil
253: */
254: lispval Lchdir(){
255: register char *filenm;
256:
257: chkarg(1,"chdir");
258: filenm = (char *) verify(lbot->val,"chdir - non symbol or string arg");
259: if(chdir(filenm)>=0)
260: return(tatom);
261: else
262: return(nil);
263: }
264:
265: /* ==========================================================
266: -
267: - ascii - convert from number to ascii character
268: -
269: - form:(ascii number)
270: -
271: - the number is checked so that it is in the range 0-255
272: - then it is made a character and returned
273: - =========================================================*/
274:
275: lispval
276: Lascii()
277: {
278: register lispval handy;
279:
280: handy = lbot->val; /* get argument */
281:
282: if(TYPE(handy) != INT) /* insure that it is an integer */
283: { error("argument not an integer",FALSE);
284: return(nil);
285: }
286:
287: if(handy->i < 0 || handy->i > 0377) /* insure that it is in range*/
288: { error("argument is out of ascii range",FALSE);
289: return(nil);
290: }
291:
292: strbuf[0] = handy->i ; /* ok value, make into a char */
293: strbuf[1] = NULL_CHAR;
294:
295: /* lookup and possibly intern the atom given in strbuf */
296:
297: return( (lispval) getatom(TRUE) );
298: }
299:
300: /*
301: * boole - maclisp bitwise boolean function
302: * (boole k x y) where k determines which of 16 possible bitwise
303: * truth tables may be applied. Common values are 1 (and) 6 (xor) 7 (or)
304: * the result is mapped over each pair of bits on input
305: */
306: lispval
307: Lboole(){
308: register x, y;
309: register struct argent *mynp;
310: int k;
311:
312: if(np - lbot < 3)
313: error("Boole demands at least 3 args",FALSE);
314: mynp = lbot+AD;
315: k = mynp->val->i & 15;
316: x = (mynp+1)->val->i;
317: for(mynp += 2; mynp < np; mynp++) {
318: y = mynp->val->i;
319: switch(k) {
320:
321: case 0: x = 0;
322: break;
323: case 1: x = x & y;
324: break;
325: case 2: x = y & ~x;
326: break;
327: case 3: x = y;
328: break;
329: case 4: x = x & ~y;
330: break;
331: /* case 5: x = x; break; */
332: case 6: x = x ^ y;
333: break;
334: case 7: x = x | y;
335: break;
336: case 8: x = ~(x | y);
337: break;
338: case 9: x = ~(x ^ y);
339: break;
340: case 10: x = ~x;
341: break;
342: case 11: x = ~x | y;
343: break;
344: case 12: x = ~y;
345: break;
346: case 13: x = x | ~y;
347: break;
348: case 14: x = ~x | ~y;
349: break;
350: case 15: x = -1;
351: }
352: }
353: return(inewint(x));
354: }
355: lispval
356: Lfact()
357: {
358: register lispval result, handy;
359: register itemp;
360: Savestack(3); /* fixup entry mask */
361:
362: result = lbot->val;
363: if(TYPE(result)!=INT) error("Factorial of Non-fixnum. If you want me\
364: to calculate fact of > 2^30 We will be here till doomsday!.",FALSE);
365: itemp = result->i;
366: protect(result = newsdot());
367: result->s.CDR=(lispval)0;
368: result->i = 1;
369: for(; itemp > 1; itemp--)
370: dmlad(result,(long)itemp,0L);
371: if(result->s.CDR)
372: {
373: Restorestack();
374: return(result);
375: }
376: handy = inewint(result->s.I);
377: pruneb(result);
378: Restorestack();
379: return(handy);
380: }
381: /*
382: * fix -- maclisp floating to fixnum conversion
383: * for the moment, mereley convert floats to ints.
384: * eventual convert to bignum if too big to fit.
385: */
386: lispval Lfix()
387: {
388: register lispval handy;
389: double floor();
390:
391: chkarg(1,"fix");
392: handy = lbot->val;
393: switch(TYPE(handy)) {
394: default:
395: error("innaproriate arg to fix.",FALSE);
396: case INT:
397: case SDOT:
398: return(handy);
399: case DOUB:
400: return(inewint((int)floor(handy->r)));
401: }
402: }
403: /*
404: * (frexp <real no>)
405: * returns a dotted pair (<exponent>. <bignum>)
406: * such that bignum is 56 bits long, and if you think of the binary
407: * point occuring after the high order bit, <real no> = 2^<exp> * <bignum>
408: *
409: * myfrexp is an assembly language routine found in bigmath.s to do exactly
410: * what is necessary to accomplish this.
411: * this routine is horribly vax specific.
412: *
413: * Lfix should probably be rewritten to take advantage of myfrexp
414: */
415: lispval
416: Lfrexp()
417: {
418: register lispval handy, result;
419: int exp, hi, lo;
420:
421: Savestack(2);
422: chkarg(1,"frexp");
423:
424: myfrexp(lbot->val->r, &exp, &hi, &lo);
425: if(lo < 0) {
426: /* normalize for bignum */
427: lo &= ~ 0xC0000000;
428: hi += 1;
429: }
430: result = handy = newdot();
431: protect(handy);
432: handy->d.car = inewint(exp);
433: if(hi==0&&lo==0) {
434: handy->d.cdr = inewint(0);
435: } else {
436: handy = handy->d.cdr = newsdot();
437: handy->s.I = lo;
438: handy = handy->s.CDR = newdot();
439: handy->s.I = hi;
440: handy->s.CDR = 0;
441: }
442: np--;
443: Restorestack();
444: return(result);
445: }
446:
447: #define SIGFPE 8
448: #define B 1073741824.0
449: static double table[] = { 1.0, B, B*B, B*B*B, B*B*B*B, 0.0};
450:
451: lispval
452: Lfloat()
453: {
454: register lispval handy,result;
455: register double sum = 0;
456: register int count;
457: chkarg(1,"float");
458: handy = lbot->val;
459: switch(TYPE(handy))
460: {
461: case DOUB: return(handy);
462:
463:
464: case INT: result = newdoub();
465: result->r = (double) handy->i;
466: return(result);
467: case SDOT:
468: {
469: for(handy = lbot->val, count = 0;
470: count < 5;
471: count++, handy = handy->s.CDR) {
472: sum += handy->s.I * table[count];
473: if(handy->s.CDR==(lispval)0) goto done;
474: }
475: kill(getpid(),SIGFPE);
476: done:
477: result = newdoub();
478: result->r = sum;
479: return(result);
480: }
481: default: errorh1(Vermisc,"Bad argument to float",nil,FALSE,0,handy);
482: /* NOTREACHED */
483: }
484: }
485: double
486: Ifloat(handy)
487: register lispval handy;
488: {
489: register double sum = 0.0; register int count=0;
490: for(; count < 5; count++, handy = handy->s.CDR) {
491: sum += handy->s.I * table[count];
492: if(handy->s.CDR==(lispval)0) goto done;
493: }
494: kill(getpid(),SIGFPE);
495: done:
496: return(sum);
497: }
498:
499: /* Lbreak ***************************************************************/
500: /* If first argument is not nil, this is evaluated and printed. Then */
501: /* error is called with the "breaking" message. */
502: lispval Lbreak() {
503:
504: if (np > lbot) {
505: printr(lbot->val,poport);
506: dmpport(poport);
507: }
508: return(error("",TRUE));
509: }
510:
511:
512: lispval
513: LDivide() {
514: register lispval result, work;
515: register struct argent *mynp;
516: lispval quo, rem, arg1, arg2; struct sdot dummy, dum2;
517: Savestack(3);
518:
519: chkarg(2,"Divide");
520: mynp = lbot;
521: work = mynp++->val;
522: switch(TYPE(work)) {
523: case INT:
524: arg1 = (lispval) &dummy;
525: dummy.I = work->i;
526: dummy.CDR = (lispval) 0;
527: break;
528: case SDOT:
529: arg1 = work;
530: break;
531: urk:
532: default:
533: error("First arg to divide neither a bignum nor int.",FALSE);
534: }
535: work = mynp->val;
536: switch(TYPE(work)) {
537: case INT:
538: arg2 = (lispval) &dum2;
539: dum2.I = work->i;
540: dum2.CDR = (lispval) 0;
541: break;
542: case SDOT:
543: arg2 = work;
544: break;
545: default:
546: goto urk;
547: }
548: divbig(arg1,arg2, &quo, &rem);
549: protect(quo);
550: if(rem==((lispval)&dummy))
551: rem = inewint(dummy.I);
552: protect(rem);
553: protect(result = work = newdot());
554: work->d.car = quo;
555: (work->d.cdr = newdot())->d.car = rem;
556: Restorestack();
557: return(result);
558: }
559:
560: lispval LEmuldiv(){
561: register struct argent * mynp = lbot+AD;
562: register lispval work, result;
563: int quo, rem;
564: Savestack(3); /* fix register mask */
565:
566: /* (Emuldiv mul1 mult2 add quo) =>
567: temp = mul1 + mul2 + sext(add);
568: result = (list temp/quo temp%quo);
569: to mix C and lisp a bit */
570:
571: Imuldiv(mynp[0].val->i, mynp[1].val->i, mynp[2].val->i,
572: mynp[3].val->i, &quo, &rem);
573: protect(result=newdot());
574: (result->d.car=inewint(quo));
575: work = result->d.cdr = newdot();
576: (work->d.car=inewint(rem));
577: Restorestack();
578: return(result);
579: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.