![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to al.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 al.c CVS log | Up to [CSRG BSD Unix] / 43BSD / contrib / apl / src |
1.1 root 1: static char Sccsid[] = "al.c @(#)al.c 1.1 10/1/82 Berkeley ";
2: #
3: /*
4: * monadic epsilon and encode /rww
5: */
6: #include "apl.h"
7: #include <signal.h>
8:
9: ex_meps()
10: {
11: struct item *p;
12: register i,j;
13: char *a,*b,*c;
14: int dim0,dim1;
15: char *xpcp;
16:
17: p = fetch1();
18: if ( p->rank > 2 || p->type != CH )
19: error("execute C");
20: /*get out if nothing to do, apr 2-23-77 */
21: if (p->size == 0){
22: return;
23: }
24: b = (char *)p->datap;
25: dim0 = p->rank < 2 ? 1 : p->dim[0];
26: dim1 = p->rank < 2 ? p->size : p->dim[1];
27: a = alloc ( dim1+1 );
28: xpcp = pcp;
29: for ( i=0; i<dim0 ; i++) {
30: copy(CH, b, a, dim1);
31: a[dim1] = '\n';
32: c = compile(a,1);
33: if(c != 0){
34: execute(c);
35: free(c);
36: } else {
37: free(a);
38: error("");
39: }
40: b += dim1;
41: if(i < dim0-1)
42: pop();
43: }
44: free(a);
45: pcp = xpcp;
46: p = *--sp;
47: pop();
48: *sp++ = p;
49: }
50:
51: ex_menc()
52: {
53: struct item *p;
54:
55: p = fetch1();
56: if ( p->type == DA )
57: menc1(); /*
58: else
59: return (char argument unchanged); */
60: }
61:
62:
63: ex_list() /* List a function on the terminal */
64: {
65: register char lastc;
66: register struct nlist *n;
67: register line;
68: char c;
69:
70:
71: /* Check for valid function */
72:
73: n = (struct nlist *)*--sp;
74: if (n->type != LV)
75: error("fnlist B");
76:
77:
78: /* If a function, locate it in workspace file and
79: * print on the terminal in formatted form.
80: */
81:
82: switch(((struct nlist *)n)->use){
83: default:
84: error("fnlist T");
85:
86: case NF:
87: case MF:
88: case DF:
89: SEEKF(wfile, (long)n->label, 0);
90: line = 0;
91: lastc = 0;
92: putchar('\n');
93:
94: while(READF(wfile, &c, 1) > 0){
95:
96: if (!c){
97: putchar('\n');
98: return;
99: }
100:
101: switch(lastc){
102: case '\n':
103: printf("[%d]", ++line);
104: case 0:
105: putchar('\t');
106: }
107: putchar(lastc=c);
108: }
109: error("workspace eof");
110: }
111: }
112:
113:
114: ex_crp() /* dredge up a function and put it into an array*/
115: {
116: char name[NAMS];
117: char *c, *c2;
118: struct nlist *np;
119: struct item *p;
120: int len, dim0, dim1;
121: register i;
122: register char *dp;
123:
124: p = fetch1();
125: if ( p->size == 0 || p->rank >1 || p->size >= NAMS )
126: error("Lcr C");
127: /* set up the name in search format */
128: copy(CH, p->datap, name, p->size);
129: name[p->size] = '\0';
130: np = nlook(name);
131: /* if not found then domain error */
132: if ( !np->namep )
133: error("Lcr D");
134: switch(np->use){
135: default:
136: error("Lcr D");
137: case MF:
138: case DF:
139: case NF: /* only allow functions */
140: ;
141: }
142: /* set up new array */
143: dim0 = 0;
144: dim1 = 0;
145: ifile = DUPF(wfile);
146: SEEKF( ifile, (long)np->label, 0); /* look up function */
147: /* compute max width and height */
148: while ( c2 = c = rline(0) ){
149: while ( *c2++ != '\n' ){}
150: dim0++;
151: len = c2 - c - 1;
152: dim1 = dim1 < len ? len : dim1;
153: free(c);
154: }
155: pop(); /* release old variable */
156: /* create new array and put function in */
157: p = newdat ( CH, 2, dim0*dim1 );
158: p->rank = 2;
159: p->dim[0] = dim0;
160: p->dim[1] = dim1;
161: dp = (char *)(p->datap);
162: SEEKF( ifile, (long)np->label, 0);
163: while ( c2 = c = rline(0) ){
164: for ( i=0; i<dim1; i++)
165: if ( *c != '\n' )
166: *dp++ = *c++;
167: else
168: *dp++ = ' '; /* fill w/blanks*/
169: free(c2);
170: }
171: /* put the new array on the stack */
172: *sp++ = p;
173: /* reset the current file */
174: CLOSEF(ifile);
175: ifile = 0;
176: }
177:
178: menc1() /* change numbers into characters */
179: {
180: struct item *p, *q;
181: register i,j,numsz;
182: data *dp;
183: int total,param[4];
184:
185: /* zeroize size information vector */
186: for ( i=0; i<4; i++ )
187: param[i] = 0;
188: /* pick up the argument */
189: p = fetch1();
190: if(p->rank > 2)
191: error("format R");
192: dp = p->datap;
193: /* find the maximum # of chars in any # */
194: for(i=0; i<p->size; i++)
195: epr1(*dp++, param);
196: numsz = param[1] + param[2] + !!param[2] + param[3] + 1;
197: /* rowsize is max # size x last dim */
198: rowsz = p->rank ? p->dim[p->rank-1] : 1;
199: rowsz *= numsz;
200: /* row size x # of rows (incl blank) */
201: total = p->size * numsz;
202: for( j=i=0; i<p->rank; i++ )
203: if ( p->dim[i] != 1)
204: if ( j++ > 1 )
205: total += rowsz;
206: /* make new data and fill with blanks */
207: if(p->rank == 2){
208: q = newdat(CH, 2, total);
209: q->dim[0] = total/rowsz;
210: q->dim[1] = rowsz;
211: } else {
212: /* rank = 0 or 1 */
213: q = newdat( CH, 1, total);
214: q->dim[0] = rowsz;
215: }
216: mencptr = (char *)(q->datap);
217: for ( i=0; i<total; i++)
218: *mencptr++ = ' ';
219: mencptr = (char *)(q->datap);
220: /* use putchar() to fill up the array */
221: mencflg = 2;
222: ex_hprint();
223: mencflg = 0;
224: /* put it on the stack */
225: /* pop(); /* done by ex_hprint() */
226: *sp++ = q;
227: }
228:
229:
230: ex_run()
231: {
232: register struct item *p;
233: register data *dp;
234: register int *p2;
235: char ebuf[100];
236: int i;
237: int *run();
238:
239: p = fetch1();
240: if(p->type != CH || p->rank != 1)
241: error("Lrun D");
242: copy(CH, p->datap, ebuf, p->size);
243: ebuf[p->size] = 0;
244: p2 = run(ebuf);
245: p = newdat(DA, 1, 0);
246: pop();
247: *sp++ = p;
248: }
249:
250: int *run(s)
251: char *s;
252: {
253: register p;
254: static int a[3];
255: int (*oldint)(), (*oldquit)();
256:
257: oldint = signal(SIGINT, SIG_IGN);
258: oldquit = signal(SIGQUIT, 1);
259: if(a[0]=FORKF(1)){
260: while((p = wait(a+1)) != -1)
261: if(p == a[0])
262: break;
263: } else {
264: execl("/bin/sh", "-", "-c", s, 0);
265: WRITEF(1, "can't find shell\n", 17);
266: exit(1);
267: }
268: a[2] = (a[1]>>8)&0377;
269: a[1] &= 0377;
270: signal(SIGINT, oldint);
271: signal(SIGQUIT, oldquit);
272: return(a);
273: }
274:
275: ex_dfmt()
276: {
277: register char *cp, *ecp;
278: register data *fp;
279: register j;
280: struct item *lp, *rp, *ip;
281: data *dp;
282: unsigned nrow, ncol, rowlen, inc, wid;
283: int i, sign, decpt;
284:
285: /* Dyadic format. This routine is a little crude and should
286: * probably be rewritten to take advantage of other conversion
287: * routines. Nonetheless, it does do dyadic formatting for
288: * scalars, vectors, and 2-dimensional arrays when the left
289: * argument is a 2-element or appropriate-length vector
290: * specifying non-exponential ("F format") conversion.
291: */
292:
293: lp = fetch2();
294: rp = sp[-2];
295: nrow = (rp->rank < 2) ? 1 : rp->dim[0];
296: ncol = rp->rank ? rp->dim[rp->rank-1] : 1;
297: inc = (lp->size != 2) * 2;
298:
299:
300: /* Check validity of arguments. */
301:
302: if (lp->rank > 1 || lp->size <= 1 || rp->rank > 2
303: || lp->type != DA || rp->type != DA
304: || (lp->size != 2 && lp->size != 2*ncol))
305: error("dfmt D");
306:
307: for(fp=lp->datap,i=0; i < lp->size; i += 2,fp += 2){
308: if (fp[0] <= 0.0 || fp[1] < 0.0)
309: error("dfmt D");
310: fp[0] = (data)((int)(0.5+fp[0]));
311: fp[1] = (data)((int)(0.5+fp[1]));
312: }
313:
314:
315: /* Allocate result array */
316:
317: for(i=rowlen=0,fp=lp->datap; i < ncol; i++, fp += inc)
318: rowlen += (int)*fp;
319:
320: ip = newdat(CH, rp->rank ? rp->rank : 1, rowlen*nrow);
321:
322: if (rp->rank < 2)
323: ip->dim[0] = rowlen;
324: else {
325: ip->dim[0] = nrow;
326: ip->dim[1] = rowlen;
327: }
328:
329:
330: /* Fill it up. The special case "fabs(*dp) < 1.0 && !fp[1]"
331: * insures that a zero is printed when 0 fractional digits are
332: * specified and the number being converted is less than one.
333: */
334:
335: cp = (char *)ip->datap;
336: dp = rp->datap;
337: while(nrow--)
338: for(i=0,fp=lp->datap; i < ncol; i++, dp++, fp += inc){
339: if (fp[1] == 0.0 && fabs(*dp) < 1.0)
340: *dp = 0.0;
341: ecp = ecvt(*dp, (int)(0.5+fp[0]), &decpt, &sign);
342: decpt += (*dp == 0.0 && fp[1] == 0.0);
343: j = fp[0];
344: wid = !!sign + fp[1] + !!fp[1] + ((decpt>0)?decpt:0);
345: if (j < wid)
346: while(j--)
347: *cp++ = '*'; /* not wide enough */
348: else {
349: while(j > wid){ /* leading spaces */
350: *cp++ = ' ';
351: j--;
352: }
353: if (sign){ /* possible - sign */
354: *cp++ = '-';
355: j--;
356: }
357: while(decpt > 0){ /* whole number part */
358: *cp++ = *ecp++;
359: j--;
360: decpt--;
361: }
362: if (j--){ /* fraction, if any */
363: *cp++ = '.';
364: while(decpt++ < 0 && j){
365: j--;
366: *cp++ = '0';
367: }
368: while(j--)
369: *cp++ = *ecp++;
370: }
371: }
372: }
373:
374: pop();
375: pop();
376: *sp++ = ip;
377:
378: }
379:
380: ex_mfmt()
381: {
382: ex_menc();
383: }
384:
385: ex_nc()
386: {
387: register struct nlist *np;
388: register struct item *p;
389: register char *q;
390: int i;
391: char buf[40];
392:
393: p = fetch1();
394: if(p->type != CH)
395: error("Lnc T");
396: if(p->size >= 40 || p->rank > 1)
397: error("Lnc D");
398: copy(CH, p->datap, buf, p->size);
399: buf[p->size] = 0;
400: np = nlook(buf);
401: i = 0;
402: if(np != 0)
403: switch(np->use){
404: case 0:
405: i = 0; break;
406: case MF:
407: case NF:
408: case DF:
409: i = 3; break;
410: case DA:
411: case CH:
412: case LV:
413: i = 2; break;
414: default:
415: printf("unknown Lnc type = %d\n", np->use);
416: i = 4;
417: }
418: p = newdat(DA, 0, 1);
419: p->datap[0] = i;
420: pop();
421: *sp++ = p;
422: }
423:
424: ex_nl()
425: {
426:
427: struct item *ip;
428: struct nlist *np;
429: data *dp;
430: register char *cp, *cp2;
431: register i;
432: int count, maxlen;
433: char tlist[NTYPES];
434:
435:
436: /* Namelist quad function. This is monadic (dyadic not
437: * implemented). The argument is a list of types:
438: * 1: labels
439: * 2: variables
440: * 3: functions
441: * whose names are desired. The result is a character array
442: * containing all defined names (in no particular order) of
443: * the specified type(s). The number of rows in the matrix
444: * is the number of names; the number of columns is the
445: * same as the longest name (other names are space-filled).
446: */
447:
448: ip = fetch1();
449: if (ip->rank > 1 || ip->type != DA)
450: error("Lnl D");
451:
452: for(i=0; i < NTYPES; i++) tlist[i] = 0;
453: for(dp=ip->datap; dp < ip->datap+ip->size; dp++)
454: switch((int)*dp){
455: case 1: tlist[LBL] = 1; break;
456: case 2: tlist[CH] = tlist[DA] = 1; break;
457: case 3: tlist[NF] = tlist[MF] = tlist[DF] = 1; break;
458: default:error("Lnl D"); break;
459: }
460:
461: count = maxlen = 0;
462: for(np=nlist; np < &nlist[NLS]; np++){
463: if (np->use < NTYPES && tlist[np->use]){
464: count++;
465: if ((i=strlen(np->namep)) > maxlen)
466: maxlen = i;
467: }
468: }
469:
470:
471: ip = newdat(CH, 2, count*maxlen);
472: ip->dim[0] = count;
473: ip->dim[1] = maxlen;
474: cp = ip->datap;
475:
476: for(np=nlist; np < &nlist[NLS]; np++)
477: if (np->use < NTYPES && tlist[np->use])
478: for(cp2 = &np->namep[i=0]; i < maxlen; i++)
479: if (*cp2)
480: *cp++ = *cp2++;
481: else
482: *cp++ = ' ';
483:
484: pop();
485: *sp++ = ip;
486: }
487:
488: strlen(p)
489: register char *p;
490: {
491: register i;
492:
493: for(i=0; *p; i++,p++);
494: return(i);
495: }
496:
497: ex_prws(){
498:
499: register struct nlist *np;
500: register struct item *ip;
501: register i;
502:
503: /* Print workspace in ASCII format */
504:
505: printf("origin = %d\nwidth = %d\ndigits = %d\n\n\n",
506: thread.iorg, thread.width, thread.digits);
507: for(np=nlist; np < &nlist[NLS]; np++)
508: switch(np->use){
509: case CH:
510: case DA:
511: printf("%s { ", np->namep);
512: ip = np->itemp;
513: if (ip->rank){
514: for(i=0; i < ip->rank; i++)
515: printf("%d ", ip->dim[i]);
516: printf("R\n");
517: }
518: *sp++ = np;
519: ex_print();
520: pop();
521: putchar('\n');
522: break;
523:
524: case NF:
525: case MF:
526: case DF:
527: *sp++ = np;
528: ex_list();
529: /* pop(); in ex_list() */
530: putchar('\n');
531: break;
532: }
533: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.