![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to a0.c CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 3BSD / cmd / apl|
Return to a0.c CVS log | Up to [CSRG BSD Unix] / 3BSD / cmd / apl |
1.1 root 1: #include "apl.h"
2: /*#include "/usr/sys/tty.h" /* pick up TECO-mode bit */
3: #define APLMOD 01000
4: short TERMtype = 0 ; /* for now ( very stupid variable) */
5:
6: short chartab[];
7: char partab[1];
8:
9: int ifile = 0,
10: ofile = 1;
11:
12: data zero = 0.0;
13: data one = 1.0;
14: data pi = 3.141592653589793238462643383;
15: data maxexp = 88.0;
16:
17: struct env thread = {
18: 1.0e-13, 1,
19: 9, 72
20: };
21:
22: main(ac,av)
23: char **av;
24: {
25: register a, c;
26: int fflag;
27: int intr();
28: int floatover();
29: extern headline[];
30:
31: memstart = sbrk(0);
32:
33: Reset();
34: signal(8,floatover);
35: if(--ac&&*av[1]=='-')
36: ++echoflg;
37: time(stime);
38: setterm(1); /* turn off APL mode */
39: aprintf(headline);
40:
41: if(ttyname(0) == 'x')
42: echoflg++;
43:
44: a = "apl_ws";
45: while((wfile = open(a, 2)) < 0) {
46: c = creat(a, 0666);
47: if(c < 0) {
48: aprintf("cannot create apl_ws");
49: exit(0);
50: }
51: close(c);
52: }
53:
54: fflag = 1;
55:
56: sp = stack;
57: signal(2, intr);
58: setexit();
59:
60: if(fflag) {
61: fflag =0;
62: if((a=open("continue",0)) < 0) {
63: aprintf("clear ws\n");
64: goto loop;
65: }
66: wsload(a);
67: aprintf(" continue\n");
68: }
69:
70: loop:
71: while(sp > stack)
72: pop();
73: Reset();
74: signal(8,floatover);
75: if(intflg)
76: error("I");
77: if(!ifile&&ofile==1)
78: aputchar('\t');
79: a = rline(8);
80: if(a==0) {
81: if(ifile) {
82: ifile = 0;
83: goto loop;
84: }
85: ctrld();
86: }
87: c = compile(a, 0);
88: afree(a);
89: if(c == 0)
90: goto loop;
91: execute(c);
92: afree(c);
93: goto loop;
94: }
95:
96: /* this procedure is for trapping floating point exceptions, and */
97: /* then reset the program. added june 1979 */
98:
99: floatover() {
100: printf("\t\nerror -- floating point exception\n");
101: signal(8,floatover);
102: reset();
103: };
104:
105:
106:
107: setterm(toggle)
108: { TERMtype = toggle;
109: aplmod(toggle + 1);
110: }
111:
112:
113: nargs()
114: {
115: return 1;
116: }
117:
118: Reset()
119: {
120: afree(stack);
121: cs_size = STKS;
122: stack = alloc(sizeof(sp)*STKS); /* Set up internal stack */
123: sp = stack;
124: staktop = &stack[STKS-1];
125: }
126:
127: intr()
128: {
129:
130: intflg = 1;
131: signal(2, intr);
132: lseek(0, 0, 2);
133: }
134:
135: rline(s)
136: {
137: int rlcmp();
138: char line[CANBS];
139: register char *p;
140: register c, col;
141: char *cp;
142: char *dp;
143: short i;
144: int j;
145:
146: column = 0;
147: col = s;
148: p = line;
149: loop:
150: c = agetchar();
151: if(intflg)
152: error("I");
153: switch(c) {
154:
155: case '\0':
156: case -1:
157: return(0);
158:
159: case '\b':
160: if(col)
161: col--;
162: goto loop;
163:
164: case '\t':
165: col = (col+8) & ~7;
166: goto loop;
167:
168: case ' ':
169: case 016: /* cursor right */
170: col++;
171: goto loop;
172:
173: case '\r':
174: col = 0;
175: goto loop;
176:
177: default:
178: *p++ = col;
179: *p++ = c & 0177;
180: col++;
181: goto loop;
182:
183: case 033: /* escape - APL line feed */
184: for(cp=dp=line; cp<p; cp+= 2)
185: if(*cp < col) {
186: *dp++ = *cp;
187: *dp++ = cp[1];
188: }
189: p = dp;
190: aputchar('\n');
191: putto(col);
192: aputchar(')');
193: aputchar('\n');
194: putto(col);
195: column=0;
196: goto loop;
197:
198: case '\n':
199: ;
200: }
201: qsort(line, (p-line)/2, 2, rlcmp);
202: c = p[-2];
203: if(p == line)
204: c = 1; /* check for blank line */
205: *p = -1;
206: c = alloc((int)(c+3));
207: col = -1;
208: cp = c - 1;
209: for(p=line; p[0] != -1; p+=2) {
210: while(++col != p[0])
211: *++cp = ' ';
212: *++cp = p[1];
213: while(p[2] == col) {
214: if(p[3] != *cp) {
215: i = *cp ;
216: *cp = p[3];
217: break;
218: }
219: p += 2;
220: }
221: if(p[2] != col) continue;
222: while(p[2] == col) {
223: if(p[3] != *cp)
224: goto yuck;
225: p += 2;
226: }
227: i |= *cp << 8;
228: for (j=41;j>=0;j--)
229: if ((i.c[0] == chartab[j].a1) && ( i.c[1]==chartab[j].a2)) {
230: *cp = j | 0200;
231: j = 0;
232: break;
233: }
234: if(j) {
235: yuck:
236: *cp = '\n';
237: pline(c,++col);
238: error("Y E");
239: }
240: }
241: *++cp = '\n';
242: return(c);
243: }
244:
245: rlcmp(a, b)
246: char *a, *b;
247: {
248: register c;
249:
250: if(c = a[0] - b[0])
251: return(c);
252: return(a[1] - b[1]);
253: }
254:
255: pline(str, loc)
256: char *str;
257: {
258: register c, l, col;
259:
260: col = 0;
261: l = 0;
262: do {
263: c = *str++;
264: l++;
265: if(l == loc)
266: col = column;
267: aputchar(c);
268: } while(c != '\n');
269: if(col) {
270: putto(col);
271: if (TERMtype == 0)aputchar(')');
272: else aputchar('^');
273: aputchar('\n');
274: }
275: }
276:
277: putto(col)
278: {
279: while(col > column+8)
280: aputchar('\t');
281: while(col > column)
282: aputchar(' ');
283: }
284:
285: term()
286: {
287:
288: unlink("apl_ws");
289: aputchar('\n');
290: aplmod(0); /*turn off APL mode */
291: exit(0);
292: }
293:
294: fix(d)
295: data d;
296: {
297: register i;
298:
299: i = floor(d+0.5);
300: return(i);
301: }
302:
303: xeq_mark()
304: {
305: if(now_xeq.name) {
306: aprintf(now_xeq.name);
307: aprintf(" ;%d'\n", now_xeq.line);
308: }
309: now_xeq.name = now_xeq.line = 0;
310: }
311:
312: error(s)
313: char *s;
314: {
315: register c;
316: register char *cp;
317:
318: intflg = 0;
319: if(ifile)
320: close(ifile);
321: if(ofile&&ofile!=1)
322: close(ofile);
323: ifile = 0;
324: ofile = 1;
325: xeq_mark();
326: cp = s;
327: while(c = *cp++) {
328: if(c >= 'A' && c <= 'Z') {
329: switch(c) {
330:
331: case 'L':
332: c = "length";
333: break;
334: case 'I':
335: c = "\ninterrupt";
336: break;
337:
338: case 'C':
339: c = "conformability";
340: break;
341:
342: case 'S':
343: c = "syntax";
344: break;
345:
346: case 'R':
347: c = "rank";
348: break;
349:
350: case 'X':
351: c = "index";
352: break;
353:
354: case 'Y':
355: c = "character";
356: break;
357:
358: case 'M':
359: c = "memory";
360: break;
361:
362: case 'D':
363: c = "domain";
364: break;
365:
366: case 'T':
367: c = "type";
368: break;
369:
370: case 'E':
371: c = "error";
372: break;
373:
374: case 'B':
375: default:
376: c = "botch";
377: }
378: aprintf(c);
379: continue;
380: }
381: aputchar(c);
382: }
383: aputchar('\n');
384: reset();
385: };
386:
387: /* procedure to catch control d and prevent it from logging out the user*/
388:
389: ctrld(){
390: aprintf("\nto exit type \"off\nto exit and save workspace type \"continue\n");
391: reset();
392: }
393:
394: aprintf(f, a)
395: char *f;
396: {
397: register char *s;
398: register *p;
399:
400: s = f;
401: p = &a;
402: while(*s) {
403: if(s[0] == '%' && s[1] == 'd') {
404: putn(*p++);
405: s += 2;
406: continue;
407: }
408: aputchar(*s++);
409: }
410: }
411:
412: putn(n)
413: {
414: register a;
415:
416: if(n < 0) {
417: n = -n;
418: if(n < 0) {
419: aprintf("2147483648");
420: return;
421: }
422: aputchar('@'); /* apl minus sign */
423: }
424: if(a=n/10)
425: putn(a);
426: aputchar(n%10 + '0');
427: }
428: agetchar()
429: {
430: int c;
431:
432: c = 0;
433: read(ifile, &c, 1);
434: if(echoflg)
435: write(1, &c, 1);
436: return(c);
437: }
438:
439: aputchar(c)
440: register c;
441: {
442: register i;
443: unsigned char c2;
444: extern unsigned char changeoutput[];
445:
446: if(TERMtype == 1) /* ascii terminal */
447: c = changeoutput [ (0377 & c) ];
448:
449:
450: switch(c) {
451:
452: case '\0':
453: return;
454:
455: case '\b':
456: if(column)
457: column--;
458: break;
459:
460: case '\t':
461: column = (column+8) & ~7;
462: break;
463:
464: case '\r':
465: case '\n':
466: column = 0;
467: break;
468:
469: default:
470: column++;
471: }
472: /* for encode numbers */
473: if(mencflg) {
474: if(c != '\n') {
475: mencflg = 1;
476: *mencptr++ = c;
477: }
478: else
479: if(mencflg > 1)
480: mencptr += rowsz;
481: else
482: mencflg = 2;
483: return;
484: }
485: if(intflg == 0) {
486: if(c & 0200) {
487: i = chartab[c & 0177];
488: aputchar(i>>8);
489: c = i & 0177;
490: aputchar('\b');
491: }
492: c2 = c;
493: write(ofile, &c2, 1);
494: }
495: }
496:
497: fuzz(d1, d2)
498: data d1, d2;
499: {
500: double f1, f2;
501:
502: f1 = d1;
503: if(f1 < 0.)
504: f1 = -f1;
505: f2 = d2;
506: if(f2 < 0.)
507: f2 = -f2;
508: if(f2 > f1)
509: f1 = f2;
510: f1 *= thread.fuzz;
511: if(d1 > d2) {
512: if(d2+f1 >= d1)
513: return(0);
514: return(1);
515: }
516: if(d1+f1 >= d2)
517: return(0);
518: return(-1);
519: }
520:
521: pop()
522: {
523: dealloc(*--sp);
524: }
525:
526: erase(np)
527: struct nlist *np;
528: {
529: register *p;
530:
531: p = np->itemp;
532: if(p) {
533: switch(np->use) {
534: case NF:
535: case MF:
536: case DF:
537: for(; *p>0; (*p)--)
538: afree(p[*p]);
539:
540: }
541: afree(p);
542: np->itemp = 0;
543: }
544: np->use = 0;
545: }
546:
547: dealloc(p)
548: struct item *p;
549: {
550:
551: switch(p->type) {
552:
553: case DA:
554: case CH:
555: case QQ:
556: case QD:
557: case QC:
558: case EL:
559: afree(p);
560: }
561: }
562:
563: newdat(type, rank, size)
564: {
565: register i;
566: register struct item *p;
567:
568: if(rank > MRANK)
569: error("R E");
570: i = sizeof *p + rank * SINT;
571: if(type == DA)
572: i += size * SDAT; else
573: if(type == CH)
574: i += size;
575: p = alloc(i);
576: p->rank = rank;
577: p->type = type;
578: p->size = size;
579: p->index = 0;
580: if(rank == 1)
581: p->dim[0] = size;
582: p->datap = &p->dim[rank];
583: return(p);
584: }
585:
586: copy(type, from, to, size)
587: char *from, *to;
588: {
589: register i;
590: register char *a, *b;
591: int s;
592:
593:
594:
595: if((i = size) == 0)
596: return(0);
597: a = from;
598: b = to;
599: if(type == DA)
600: i *= SDAT; else
601: if(type == IN)
602: i *= SINT;
603: s = i;
604: do
605: *b++ = *a++;
606: while(--i);
607: return(s);
608: }
609:
610: fetch1()
611: {
612: return sp[-1] = fetch(sp[-1]);
613: }
614:
615: fetch2()
616: {
617: sp[-2] = fetch(sp[-2]);
618: return sp[-1] = fetch(sp[-1]);
619: }
620:
621: fetch(ip)
622: struct item *ip;
623: {
624: register struct item *p, *q;
625: char *ubset;
626: register i;
627: int c;
628:
629: p = ip;
630:
631: loop:
632: switch(p->type) {
633:
634: case QQ:
635: afree(p);
636: c = rline(0);
637: if(c == 0)
638: error("eof");
639: for(i=0; c->c[i] != '\n'; i++)
640: continue;
641: p = newdat(CH, 1, i);
642: copy(CH, c, p->datap, i);
643: goto loop;
644:
645: case QD:
646: case QC:
647: if(!ifile&&ofile==1)
648: aprintf("L>\n\t");
649: i = rline(8);
650: if(i == 0)
651: error("eof");
652: c = compile(i, 1);
653: afree(i);
654: if(c == 0)
655: goto loop;
656: i = pcp;
657: execute(c);
658: pcp = i;
659: afree(c);
660: afree(p);
661: p = *--sp;
662: goto loop;
663:
664: case DA:
665: case CH:
666: p->index = 0;
667: return(p);
668:
669: case LV:
670: if(p->use != DA) {
671: ubset = ip->namep;
672: xeq_mark();
673: while(*ubset)
674: aputchar(*ubset++);
675: error("> used before set\n");
676: }
677: p = p->itemp;
678: q = newdat(p->type, p->rank, p->size);
679: copy(IN, p->dim, q->dim, p->rank);
680: copy(p->type, p->datap, q->datap, p->size);
681: return(q);
682:
683: default:
684: error("fetch B");
685: }
686: }
687:
688: topfix()
689: {
690: register struct item *p;
691: register i;
692:
693: p = fetch1();
694: if(p->type != DA || p->size != 1)
695: error("topval C");
696: i = fix(p->datap[0]);
697: pop();
698: return(i);
699: }
700:
701: bidx(ip)
702: struct item *ip;
703: {
704: register struct item *p;
705:
706: p = ip;
707: idx.type = p->type;
708: idx.rank = p->rank;
709: copy(IN, p->dim, idx.dim, idx.rank);
710: size();
711: }
712:
713: size()
714: {
715: register i, s;
716:
717: s = 1;
718: for(i=idx.rank-1; i>=0; i--) {
719: idx.del[i] = s;
720: s *= idx.dim[i];
721: }
722: idx.size = s;
723: return(s);
724: }
725:
726: colapse(k)
727: {
728: register i;
729:
730: if(k < 0 || k >= idx.rank)
731: error("collapse X");
732: idx.dimk = idx.dim[k];
733: idx.delk = idx.del[k];
734: for(i=k; i<idx.rank; i++) {
735: idx.del[i] = idx.del[i+1];
736: idx.dim[i] = idx.dim[i+1];
737: }
738: idx.size /= idx.dimk;
739: idx.rank--;
740: }
741:
742: forloop(co, arg)
743: int (*co)();
744: {
745: register i;
746:
747: if(idx.rank == 0) {
748: (*co)(arg);
749: return;
750: }
751: for(i=0;;) {
752: while(i < idx.rank)
753: idx.idx[i++] = 0;
754: (*co)(arg);
755: while(++idx.idx[i-1] >= idx.dim[i-1])
756: if(--i <= 0)
757: return;
758: }
759: }
760:
761: access()
762: {
763: register i, n;
764:
765: n = 0;
766: for(i=0; i<idx.rank; i++)
767: n += idx.idx[i] * idx.del[i];
768: return(n);
769: }
770:
771: data
772: getdat(ip)
773: struct item *ip;
774: {
775: register struct item *p;
776: register i;
777: data d;
778:
779: p = ip;
780: i = p->index;
781: while(i >= p->size) {
782: if(i == 0)
783: error("getdat B");
784: i -= p->size;
785: }
786: if(p->type == DA) {
787: d = p->datap[i];
788: } else
789: if(p->type == CH) {
790: d = p->datap->c[i];
791: } else
792: error("getdat B");
793: i++;
794: p->index = i;
795: return(d);
796: }
797:
798: putdat(ip, d)
799: data d;
800: struct item *ip;
801: {
802: register struct item *p;
803: register i;
804:
805: p = ip;
806: i = p->index;
807: if(i >= p->size)
808: error("putdat B");
809: if(p->type == DA) {
810: p->datap[i] = d;
811: } else
812: if(p->type == CH) {
813: p->datap->c[i] = d;
814: } else
815: error("putdat B");
816: i++;
817: p->index = i;
818: }
819:
820: aplmod(xyz)
821: {
822: static firstvisit=0;
823: static short old[3], new[3];
824: static short diff;
825: if(xyz> 0) {
826: if (firstvisit == 0){
827: if(gtty(0,old)<0) {
828: diff = 0;
829: return;
830: }
831: diff = 1;
832: }
833: if (diff == 1) {
834: gtty(0, new);
835: if (xyz == 1)new[1] = 'W'|'A'<<8; /* apl terminal */
836: else new[1] = ''|'@'<<8; /* ascii terminal */
837: stty(0, new);
838: if (firstvisit)
839: if (xyz == 1)aprintf("erase%KWK kill%KAK\n\n");
840: else aprintf("erase ^H kill @\n\n");
841: }
842: firstvisit++;
843: } else {
844: if(diff)
845: stty(0, old);
846: }
847: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.