![[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] / 40BSD / cmd / lisp|
Return to lam5.c CVS log | Up to [CSRG BSD Unix] / 40BSD / cmd / lisp |
1.1 root 1: static char *sccsid = "@(#)lam5.c 34.1 10/3/80";
2:
3: #include "global.h"
4: #include "chkrtab.h"
5:
6: /*===========================================
7: -
8: - explode functions: aexplode , aexplodec, aexploden
9: - The following function partially implement the explode functions for atoms.
10: - The full explode functions are written in lisp and call these for atom args.
11: -
12: -===========================================*/
13:
14: #include "chars.h"
15: lispval
16: Lexpldx(kind,slashify)
17: int kind, slashify; /* kind = 0 => explode to characters
18: = 1 => explode to fixnums (aexploden)
19: slashify = 0 => do not quote bizarre characters
20: = 1 => quote bizarre characters
21: */
22: {
23: int typ, i;
24: char ch, *strb, strbb[BUFSIZ]; /* temporary string buffer */
25: register lispval last, handy;
26: register char *cp;
27: char Idqc = Xdqc;
28: snpand(4); /* kludge register save mask */
29:
30: chkarg(1,"expldx");
31:
32: handy = Vreadtable->a.clb;
33: chkrtab(handy);
34: handy = lbot->val;
35: *strbuf = 0;
36: typ=TYPE(handy); /* we only work for a few types */
37:
38:
39: /* put the characters to return in the string buffer strb */
40:
41: switch(typ) {
42: case STRNG:
43: if(slashify && !Xsdc)
44: errorh(Vermisc,"Can't explode without string delimiter",nil
45: ,FALSE,0,handy);
46:
47: strb = strbb;
48: if(slashify) *strb++ = Xsdc;
49: /* copy string into buffer, escape only occurances of the
50: double quoting character if in slashify mode
51: */
52: for(cp = (char *) handy; *cp; cp++)
53: {
54: if(slashify &&
55: (*cp == Xsdc || ctable[*cp]==VESC))
56: *strb++ = Xesc;
57: *strb++ = *cp;
58: }
59: if(slashify) *strb++ = Xsdc;
60: *strb = NULL_CHAR ;
61: strb = strbb;
62: break;
63:
64: case ATOM:
65: strb = handy->a.pname;
66: if(strb[0]==0) {
67: strb = strbb;
68: strbb[0] = Xdqc;
69: strbb[1] = Xdqc;
70: strbb[2] = 0;
71: } else
72: common:
73: if(slashify != 0)
74: {
75: register char *out = strbb;
76: cp = strb;
77: strb = strbb;
78: if(ctable[(*cp)&0177]==VNUM)
79: *out++ = Xesc;
80: for(; *cp; cp++)
81: {
82: if(ctable[*cp]& QUTMASK)
83: *out++ = Xesc;
84: *out++ = *cp;
85: }
86: *out = 0;
87: }
88:
89: break;
90: case INT:
91: strb = strbb;
92: sprintf(strb, "%d", lbot->val->i);
93: break;
94: case DOUB:
95: strb = strbb;
96: lfltpr(strb, lbot->val->r);
97: break;
98: case SDOT:
99: {
100: struct _iobuf _strbuf;
101: register count;
102: for((handy = lbot->val), count = 12;
103: handy->s.CDR!=(lispval) 0;
104: (handy = handy->s.CDR), count += 12);
105: strb = (char *) alloca(count);
106:
107: _strbuf._flag = _IOWRT+_IOSTRG;
108: _strbuf._ptr = strb;
109: _strbuf._cnt = count;
110: pbignum(lbot->val,&_strbuf);
111: putc(0,&_strbuf);
112: break;
113: }
114: default:
115: errorh(Vermisc,"EXPLODE ARG MUST BE STRING, SYMBOL, FIXNUM, OR FLONUM",nil,FALSE,0,handy);
116: return(nil);
117: }
118:
119:
120: if( strb[0] != NULL_CHAR ) /* if there is something to do */
121: {
122: register lispval prev;
123:
124: protect(handy = last = newdot());
125: strbuf[1] = NULL_CHAR ; /* set up for getatom */
126: atmlen = 2;
127:
128: for(i=0; ch = strb[i++]; ) {
129: switch(kind) {
130:
131: case 0: strbuf[0] = hash = ch; /* character explode */
132: last->d.car = (lispval) getatom(); /* look in oblist */
133: break;
134:
135: case 1:
136: last->d.car = inewint(ch);
137: break;
138: }
139:
140: /* advance pointers */
141: prev = last;
142: last->d.cdr = newdot();
143: last = last->d.cdr;
144: }
145:
146: /* end list with a nil pointer */
147: prev->d.cdr = nil;
148: return(handy);
149: }
150: else return(nil); /* return nil if no characters */
151: }
152:
153: /*===========================
154: -
155: - (aexplodec 'atm) returns (a t m)
156: - (aexplodec 234) returns (\2 \3 \4)
157: -===========================*/
158:
159: lispval
160: Lexpldc()
161: { return(Lexpldx(0,0)); }
162:
163:
164: /*===========================
165: -
166: - (aexploden 'abc) returns (65 66 67)
167: - (aexploden 123) returns (49 50 51)
168: -=============================*/
169:
170:
171: lispval
172: Lexpldn()
173: { return(Lexpldx(1,0)); }
174:
175: /*===========================
176: -
177: - (aexplode "123") returns (\\ \1 \2 \3);
178: - (aexplode 123) returns (\1 \2 \3);
179: -=============================*/
180:
181: lispval
182: Lexplda()
183: { return(Lexpldx(0,1)); }
184:
185: /*
186: * (argv) returns how many arguments where on the command line which invoked
187: * lisp; (argv i) returns the i'th argument made into an atom;
188: */
189:
190: lispval
191: Largv()
192: {
193: register lispval handy;
194: register index;
195: register char *base;
196: char c;
197: extern int Xargc;
198: extern char **Xargv;
199: snpand(3);
200:
201: if(lbot-np==0)protect(nil);
202: handy = lbot->val;
203:
204: if(TYPE(handy)==INT && handy->i>=0 && handy->i<Xargc) {
205: strcpy(strbuf,Xargv[handy->i]);
206: return(getatom());
207: } else {
208: return(inewint(Xargc));
209: }
210: }
211: /*
212: * (chdir <atom>) executes a chdir command
213: * if successful, return t otherwise returns nil
214: */
215: lispval Lchdir(){
216: register char *filenm;
217:
218: chkarg(1,"chdir");
219: filenm = (char *) verify(lbot->val,"chdir - non symbol or string arg");
220: if(chdir(filenm)>=0)
221: return(tatom);
222: else
223: return(nil);
224: }
225:
226: /* ==========================================================
227: -
228: - ascii - convert from number to ascii character
229: -
230: - form:(ascii number)
231: -
232: - the number is checked so that it is in the range 0-255
233: - then it is made a character and returned
234: - =========================================================*/
235:
236: lispval
237: Lascii()
238: {
239: register lispval handy;
240:
241: handy = lbot->val; /* get argument */
242:
243: if(TYPE(handy) != INT) /* insure that it is an integer */
244: { error("argument not an integer",FALSE);
245: return(nil);
246: }
247:
248: if(handy->i < 0 || handy->i > 0377) /* insure that it is in range*/
249: { error("argument is out of ascii range",FALSE);
250: return(nil);
251: }
252:
253: strbuf[0] = handy->i ; /* ok value, make into a char */
254: strbuf[1] = NULL_CHAR;
255:
256: /* lookup and possibly intern the atom given in strbuf */
257:
258: return( (lispval) getatom() );
259: }
260:
261: /*
262: * boole - maclisp bitwise boolean function
263: * (boole k x y) where k determines which of 16 possible bitwise
264: * truth tables may be applied. Common values are 1 (and) 6 (xor) 7 (or)
265: * the result is mapped over each pair of bits on input
266: */
267: lispval
268: Lboole(){
269: register x, y;
270: register lispval result;
271: register struct argent *mynp;
272: int k;
273:
274: if(np - lbot < 3)
275: error("Boole demands at least 3 args",FALSE);
276: mynp = lbot+AD;
277: k = mynp->val->i & 15;
278: x = (mynp+1)->val->i;
279: for(mynp += 2; mynp < np; mynp++) {
280: y = mynp->val->i;
281: switch(k) {
282:
283: case 0: x = 0;
284: break;
285: case 1: x = x & y;
286: break;
287: case 2: x = y & ~x;
288: break;
289: case 3: x = y;
290: break;
291: case 4: x = x & ~y;
292: break;
293: /* case 5: x = x; break; */
294: case 6: x = x ^ y;
295: break;
296: case 7: x = x | y;
297: break;
298: case 8: x = ~(x | y);
299: break;
300: case 9: x = ~(x ^ y);
301: break;
302: case 10: x = ~x;
303: break;
304: case 11: x = ~x | y;
305: break;
306: case 12: x = ~y;
307: break;
308: case 13: x = x | ~y;
309: break;
310: case 14: x = ~x | ~y;
311: break;
312: case 15: x = -1;
313: }
314: }
315: return(inewint(x));
316: }
317: lispval
318: Lfact()
319: {
320: register lispval result, handy;
321: register itemp;
322: snpand(3); /* fixup entry mask */
323:
324: result = lbot->val;
325: if(TYPE(result)!=INT) error("Factorial of Non-fixnum. If you want me\
326: to calculate fact of > 2^30 We will be here till doomsday!.",FALSE);
327: itemp = result->i;
328: protect(result = newsdot());
329: result->s.CDR=(lispval)0;
330: result->i = 1;
331: for(; itemp > 1; itemp--)
332: dmlad(result,itemp,0);
333: if(result->s.CDR) return(result);
334: (handy = newint())->i = result->i;
335: return(handy);
336: }
337: /*
338: * fix -- maclisp floating to fixnum conversion
339: * for the moment, mereley convert floats to ints.
340: * eventual convert to bignum if too big to fit.
341: */
342: lispval Lfix()
343: {
344: register lispval result, handy;
345:
346: chkarg(1,"fix");
347: handy = lbot->val;
348: switch(TYPE(handy)) {
349: default:
350: error("innaproriate arg to fix.",FALSE);
351: case INT:
352: case SDOT:
353: return(handy);
354: case DOUB:
355: if(handy->r >= 0)
356: return(inewint((int)handy->r));
357: else
358: return(inewint(((int)handy->r)-1));
359: }
360: }
361: #define SIGFPE 8
362: #define B 1073741824.0
363: static double table[] = { 1.0, B, B*B, B*B*B, B*B*B*B, 0.0};
364:
365: lispval
366: Lfloat()
367: {
368: register lispval handy,result;
369: register double sum = 0;
370: register int count;
371: chkarg(1,"float");
372: handy = lbot->val;
373: switch(TYPE(handy))
374: {
375: case DOUB: return(handy);
376:
377:
378: case INT: result = newdoub();
379: result->r = (double) handy->i;
380: return(result);
381: case SDOT:
382: {
383: for(handy = lbot->val, count = 0;
384: count < 5;
385: count++, handy = handy->s.CDR) {
386: sum += handy->s.I * table[count];
387: if(handy->s.CDR==(lispval)0) goto done;
388: }
389: kill(getpid(),SIGFPE);
390: done:
391: result = newdoub();
392: result->r = sum;
393: return(result);
394: }
395: default: errorh(Vermisc,"Bad argument to float",nil,FALSE,0,handy);
396: }
397: }
398:
399:
400: /* Lbreak ***************************************************************/
401: /* If first argument is not nil, this is evaluated and printed. Then */
402: /* error is called with the "breaking" message. */
403: lispval Lbreak() {
404: register lispval hold;
405:
406: if (np > lbot) {
407: printr(lbot->val,poport);
408: dmpport(poport);
409: }
410: return(error("",TRUE));
411: }
412:
413:
414: lispval LDivide() {
415: register lispval result, work, temp;
416: register struct argent *mynp;
417: register struct argent *lbot, *np;
418: int typ;
419: lispval quo, rem; struct sdot dummy;
420:
421: chkarg(2,"Divide");
422: mynp = lbot;
423: result = mynp->val;
424: work = (mynp+1)->val;
425:
426: if((typ=TYPE(result))==INT) {
427: protect(temp=newsdot());
428: temp->i = result->i;
429: result = temp;
430: } else if (typ!=SDOT)
431: error("First arg to divide neither a bignum nor int.",FALSE);
432: typ = TYPE(work);
433: if(typ != INT && typ != SDOT)
434: error("second arg to Divide neither an sdot nor an int.",FALSE);
435: if(typ == INT) {
436: dummy.CDR = (lispval) 0;
437: dummy.I = work->i;
438: work = (lispval) &dummy;
439: }
440: divbig(result,work, &quo, &rem);
441: protect(quo);
442: if(rem==((lispval) &dummy))
443: protect(rem = inewint(dummy.I));
444: protect(result = work = newdot());
445: work->d.car = quo;
446: (work->d.cdr = newdot())->d.car = rem;
447: return(result);
448: }
449:
450: lispval LEmuldiv(){
451: register struct argent * mynp = lbot+AD;
452: register lispval work, result;
453: int quo, rem;
454: snpand(3); /* fix register mask */
455:
456: /* (Emuldiv mul1 mult2 add quo) =>
457: temp = mul1 + mul2 + sext(add);
458: result = (list temp/quo temp%quo);
459: to mix C and lisp a bit */
460:
461: Imuldiv(mynp[0].val->i, mynp[1].val->i, mynp[2].val->i,
462: mynp[3].val->i, &quo, &rem);
463: protect(result=newdot());
464: (result->d.car=inewint(quo));
465: work = result->d.cdr = newdot();
466: (work->d.car=inewint(rem));
467: return(result);
468: }
469: static Imuldiv() {
470: asm(" emul 4(ap),8(ap),12(ap),r0");
471: asm(" ediv 16(ap),r0,*20(ap),*24(ap)");
472: }
473:
474:
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.