Commit | Line | Data |
---|---|---|
3b0178a9 KT |
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] = '\b'|'@'<<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 | } |