![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to a2.c CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 43BSD / contrib / apl / src|
Return to a2.c CVS log | Up to [CSRG BSD Unix] / 43BSD / contrib / apl / src |
1.1 root 1: static char Sccsid[] = "a2.c @(#)a2.c 1.1 10/1/82 Berkeley ";
2: #include "apl.h"
3: #include "aplmap.h"
4:
5: int chartab[];
6: char *ecvt();
7:
8: ex_print()
9: {
10:
11: if(epr0())
12: putchar('\n');
13: }
14:
15: ex_hprint()
16: {
17:
18: epr0();
19: pop();
20: }
21:
22: epr0()
23: {
24: register struct item *p;
25: register data *dp;
26: register i;
27: int j;
28: int param[4];
29:
30: p = fetch1();
31: if(p->type == DU)
32: return(0);
33: if(p->size == 0)
34: return(1);
35: if(p->type == DA) {
36:
37: /* Use "epr1()" to figure out the maximum field width
38: * required by any of the values to be printed.
39: */
40:
41: for(i=0; i<4; i++)
42: param[i] = 0;
43: dp = p->datap;
44: for(i=0; i<p->size; i++)
45: epr1(*dp++, param);
46: i = param[1] + param[2]; /* size if fp */
47: if(i > thread.digits)
48: i += 100; /* set "e" format flag */
49: if(param[2])
50: i++;
51: if(i > param[0]+5) {
52: i = param[0] + 5; /* size if ep */
53: param[1] = param[0];
54: param[2] = -1;
55: }
56: if(param[3])
57: i++; /* sign */
58: i++; /* leading space */
59: param[0] = i;
60: dp = p->datap;
61: }
62: bidx(p);
63: for(i=1; i<p->size; i++) {
64: if(intflg)
65: break;
66: if(p->type == CH) {
67: j = getdat(p);
68: putchar(j);
69: } else
70: epr2(*dp++, param);
71: for(j=p->rank-2; j>=0; j--)
72: if(i%idx.del[j] == 0)
73: putchar('\n'); /* end of dimension reached */
74: }
75: if(p->type == CH) {
76: j = getdat(p);
77: putchar(j);
78: } else
79: epr2(*dp, param);
80: return(1);
81: }
82:
83: epr1(d, param)
84: data d;
85: int *param;
86: {
87: double f;
88: register a;
89: register char *c;
90: int dp, sg;
91:
92:
93: /* This routine figures out the field with required by the value
94: * "d". It adjusts the four elements of "param" so that they
95: * contain the maximum of their old values or the requirements for
96: * the current data item.
97: *
98: * param[0] = number of significant digits
99: * param[1] = number of digits to left of decimal point
100: * param[2] = number of digits to right of decimal point
101: * param[3] = 0 if positive, 1 if negative
102: */
103:
104: f = d;
105: c = ecvt(f, thread.digits, &dp, &sg);
106: if (f == zero) /* kludge due to change in ecvt */
107: dp = 1;
108: a = thread.digits;
109: while(c[a-1]=='0' && a>1)
110: a--;
111: if(a > param[0]) /* sig digits */
112: param[0] = a;
113: a -= dp;
114: if(a < 0)
115: a = 0;
116: if(a > param[2]) /* digits to right of dp */
117: param[2] = a;
118: if(dp > param[1]) /* digits to left of dp */
119: param[1] = dp;
120: param[3] |= sg; /* and sign */
121: }
122:
123: epr2(d, param)
124: int *param;
125: data d;
126: {
127: register i;
128: register char *c, *mc;
129: double f;
130: int dp, sg;
131:
132: if(param[0]+column > thread.width && !mencflg) {
133: putchar('\n');
134: putto(param[0]);
135: }
136: f = d;
137: c = ecvt(f, thread.digits, &dp, &sg);
138: if (f == zero)
139: dp = 1; /* kludge due to change in ecvt */
140: mc = c + thread.digits;
141: putchar(' ');
142: sg = sg? '-': ' '; /* '-' used to be '"' */
143: if(param[2] < 0) {
144: if(param[3])
145: putchar(sg);
146: for(i=0; i<param[1]; i++) {
147: putchar(*c++);
148: if(i == 0)
149: putchar('.');
150: }
151: putchar('e');
152: dp--;
153: if(dp < 0) {
154: putchar('-'); /* '=' used to be '"' */
155: dp = -dp;
156: } else
157: putchar('+'); /* apl style plus sign, used to be ':' */
158: putchar(dp/10 + '0');
159: putchar(dp%10 + '0');
160: return;
161: }
162: i = dp;
163: if(i < 0)
164: i = 0;
165: for(; i<param[1]; i++)
166: putchar(' ');
167: if(param[3])
168: putchar(sg);
169: for(i=0; i<dp; i++)
170: if(c >= mc)
171: putchar('0'); else
172: putchar(*c++);
173: for(i=0; i<param[2]; i++) {
174: if(i == 0)
175: putchar('.');
176: if(dp < 0) {
177: putchar('0');
178: dp++;
179: } else
180: if(c >= mc)
181: putchar('0'); else
182: putchar(*c++);
183: }
184: }
185:
186: error(s)
187: char *s;
188: {
189: register c;
190: register char *cp, *cs;
191:
192: intflg = 0;
193: if(ifile) {
194: CLOSEF(ifile);
195: ifile = 0;
196: }
197: cp = s;
198: while(c = *cp++) {
199: if(c >= 'A' && c <= 'Z') {
200: switch(c) {
201:
202: case 'I':
203: cs = "\ninterrupt";
204: break;
205:
206: case 'L':
207: cs = "L";
208: break;
209:
210: case 'C':
211: cs = "conformability";
212: break;
213:
214: case 'S':
215: cs = "syntax";
216: break;
217:
218: case 'R':
219: cs = "rank";
220: break;
221:
222: case 'X':
223: cs = "index";
224: break;
225:
226: case 'Y':
227: cs = "character";
228: break;
229:
230: case 'M':
231: cs = "memory";
232: break;
233:
234: case 'D':
235: cs = "domain";
236: break;
237:
238: case 'T':
239: cs = "type";
240: break;
241:
242: case 'E':
243: cs = "error";
244: break;
245:
246: case 'P':
247: cs = "programmer";
248: break;
249:
250: case 'B':
251: cs = "botch";
252: break;
253:
254: default:
255: putchar(c);
256: continue;
257: }
258: printf(cs);
259: continue;
260: }
261: putchar(c);
262: }
263: putchar('\n');
264: if (prwsflg) exit(0); /* if "prws", just exit */
265: /*
266: * produce traceback and mark state indicator.
267: */
268: tback(0);
269: if(gsip)
270: gsip->suspended = 1;
271: else {
272: while(sp > stack)
273: pop(); /* zap garbage */
274: reset();
275: }
276: mainloop(); /* reenter mainloop */
277: }
278:
279: printf(f, a)
280: char *f;
281: {
282: register char *s, *cp;
283: register *p;
284:
285: s = f;
286: p = &a;
287: while(*s) {
288: if(s[0] == '%')
289: switch(s[1]){
290: case 'd':
291: putn(*p++);
292: s += 2;
293: continue;
294: case 'o':
295: puto(*p++);
296: s += 2;
297: continue;
298: case 's':
299: cp = (char *)*p++;
300: s += 2;
301: while(*cp)
302: putchar(*cp++);
303: continue;
304: case 'f':
305: putf(p);
306: p += 4; /* 4 words per floating arg */
307: s += 2;
308: continue;
309: }
310: putchar(*s++);
311: }
312: }
313:
314: putn(n)
315: {
316: register a;
317:
318: if(n < 0) {
319: n = -n;
320: if(n < 0) {
321: printf("32768");
322: return;
323: }
324: putchar('-'); /* apl minus sign, was '"' */
325: }
326: if(a=n/10)
327: putn(a);
328: putchar(n%10 + '0');
329: }
330:
331: putf(p)
332: data *p;
333: {
334: int param[4];
335: register int i;
336:
337: param[1] = param[2] = param[3] = param[0] = 0;
338: epr1(*p, param);
339: i = param[1] + param[2]; /* size if fp */
340: if(i > thread.digits)
341: i += 100;
342: if(param[2])
343: i++;
344: if(i > param[0]+5) {
345: i = param[0] + 5; /* size if ep */
346: param[1] = param[0];
347: param[2] = -1;
348: }
349: if(param[3])
350: i++; /* sign */
351: i++; /* leading space */
352: param[0] = i;
353: epr2(*p, param);
354: /*
355: * register i,j;
356: *
357: * i = *p;
358: * j = (*p * 1000.0) - (i * 1000.0);
359: * putn(i);
360: * putchar('.');
361: * putchar('0' + j/100);
362: * putchar('0' + (j/10)%10);
363: * putchar('0' + j%10);
364: */
365: }
366:
367: puto(n)
368: {
369: if(n&0177770)
370: puto( (n>>3) & 017777);
371: putchar( '0' + (n&07));
372: }
373:
374: getchar()
375: {
376: int c;
377:
378: c = 0;
379: if(READF(ifile, &c, 1) == 1 && echoflg == 1 && !ifile)
380: WRITEF(1, &c, 1);
381:
382: /* The following code converts the input character
383: * to the ASCII equivalent (internal format) if
384: * terminal character mapping is in force.
385: */
386:
387: if (apl_term && c >= 041 && !ifile) c = map_ascii[(c&0177)-041];
388: if (c && protofile && ifile == 0) WRITEF(protofile, &c, 1);
389:
390: return(c);
391: }
392:
393: putchar(c)
394: {
395: register i;
396:
397:
398: /* This is the basic character output routine. If "mencflg"
399: * is zero, output is performed on file descriptor 1. If
400: * "menclfg" is non-zero, output is placed into the buffer
401: * pointed to by "mencptr".
402: */
403:
404: if(mencflg) { /* Format operator */
405: if(c != '\n') {
406: mencflg = 1;
407: *mencptr++ = c;
408: }
409: else
410: if(mencflg > 1)
411: mencptr += rowsz;
412: else
413: mencflg = 2;
414: return;
415: }
416:
417:
418: switch(c){ /* Normal output */
419:
420: case '\0':
421: return;
422:
423: case '\b':
424: if(column)
425: column--;
426: break;
427:
428: case '\t':
429: column = (column+8) & ~7;
430: break;
431:
432: case '\r':
433: case '\n':
434: column = 0;
435: break;
436:
437: default:
438: column++;
439: }
440:
441: if (column > thread.width) printf("\n "); /* adjust for width */
442:
443: if(intflg == 0) {
444: if(c & 0200) {
445: i = chartab[c & 0177];
446: putchar(i>>8);
447: c = i & 0177;
448: putchar('\b');
449: }
450:
451: if(protofile)
452: WRITEF(protofile, &c, 1);
453:
454:
455: /* The following code converts the internal value
456: * to the APL character for modified terminals
457: * if the APL conversion was requested.
458: */
459:
460: if (apl_term && c >= 041)
461: c = map_apl[c-041];
462: #ifdef PURDUE_EE
463: if (apl_term && c == 010)
464: c = '^';
465: #endif
466:
467: WRITEF(1, &c, 1);
468: #ifdef NBUF
469: if (c == '\n' && !prwsflg)
470: newbuf(files[1].fd_buf, 1);
471: #endif
472: }
473: }
474:
475: char *ty[] = {
476: 0,"DA","CH","LV","QD","QQ","IN","EL","NF","MF","DF","QC","QV","DU","QX","LB"
477: };
478:
479: dstack()
480: {
481: register struct item **p;
482: register i,n;
483:
484: p = sp;
485: n = 0;
486: while(--p > stack){
487: printf("\t%o: sp[%d]: type = ", p, --n);
488: if((i=(*p)->type) >= 0 && i <= LBL && ty[i])
489: printf(ty[i]);
490: else
491: printf("%d", (*p)->type);
492: switch(i){
493: default:
494: putchar('\n');
495: break;
496: case LV:
497: printf(", n = %s\n", ((struct nlist *)*p)->namep);
498: break;
499:
500: case CH:
501: if((*p)->size == 0)
502: goto nullone;
503: if((*p)->rank == 1){
504: printf(", \"");
505: for(i=0; i<(*p)->size; i++)
506: putchar(((struct chrstrct *)(*p)->datap)->c[i]);
507: printf("\"\n");
508: } else
509: goto rnk;
510: break;
511:
512: case DA:
513: case LBL:
514: if((*p)->size == 0)
515: goto nullone;
516: if((*p)->rank == 0){
517: printf(", v = %f\n", (*p)->datap[0]);
518: }
519: break;
520: rnk:
521: printf(", rank = %d\n", (*p)->rank);
522: break;
523:
524: nullone:
525: printf(", <null>\n");
526: break;
527: }
528: }
529: putchar('\n');
530: }
531:
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.