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