![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to mk.c CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Research Unix] / researchv10no / cmd / efl|
Return to mk.c CVS log | Up to [Research Unix] / researchv10no / cmd / efl |
1.1 root 1: #include "defs"
2:
3:
4: ptr mkcomm(s)
5: register char *s;
6: {
7: register ptr p;
8: register char *t;
9:
10: for(p = (int *)commonlist ; p ; p = p->nextp)
11: if(equals(s, ((struct comentry *)p->datap)->comname))
12: return(p->datap);
13:
14: p = (int *)ALLOC(comentry);
15: for(t = p->comname ; *t++ = *s++ ; ) ;
16: p->tag = TCOMMON;
17: p->blklevel = (blklevel>0? 1 : 0);
18: commonlist = mkchain(p, commonlist);
19: return(commonlist->datap);
20: }
21:
22:
23:
24:
25: ptr mkname(s)
26: char *s;
27: {
28: char *copys();
29: register ptr p;
30:
31: if( (p = (int *)name(s,1)) == 0)
32: {
33: p = (int *)name(s,0);
34: p->tag = TNAME;
35: p->blklevel = blklevel;
36: }
37: return(p);
38: }
39:
40: ptr mknode(t, o, l, r)
41: int t,o;
42: register ptr l;
43: register ptr r;
44: {
45: register struct exprblock *p;
46: ptr q;
47: int lt, rt;
48: int ll, rl;
49: ptr mksub1(), mkchcon();
50:
51: p = (struct exprblock *)allexpblock();
52: TEST fprintf(diagfile, "mknode(%d,%d,%o,%o) = %o\n", t, o, l, r, p);
53:
54: top:
55: if(t!=TLIST && t!=TCONST && l!=0 && l->tag==TERROR)
56: {
57: frexpr(r);
58: frexpblock(p);
59: return(l);
60: }
61:
62: if(r!=0 && r->tag==TERROR)
63: {
64: frexpr(l);
65: frexpblock(p);
66: return(r);
67: }
68: p->tag = t;
69: p->subtype = o;
70: p->leftp = l;
71: p->rightp = r;
72:
73: switch(t)
74: {
75: case TAROP:
76: ckdcl(l);
77: ckdcl(r);
78: switch(lt = l->vtype)
79: {
80: case TYCHAR:
81: case TYSTRUCT:
82: case TYLOG:
83: exprerr("non-arithmetic operand of arith op","");
84: goto err;
85: }
86:
87: switch(rt = r->vtype)
88: {
89: case TYCHAR:
90: case TYSTRUCT:
91: case TYLOG:
92: exprerr("non-arithmetic operand of arith op","");
93: goto err;
94: }
95: if(lt==rt || (o==OPPOWER && rt==TYINT) )
96: p->vtype = lt;
97: else if( (lt==TYREAL && rt==TYLREAL) ||
98: (lt==TYLREAL && rt==TYREAL) )
99: p->vtype = TYLREAL;
100: else if(lt==TYINT)
101: {
102: l = coerce(rt,l);
103: goto top;
104: }
105: else if(rt==TYINT)
106: {
107: r = coerce(lt,r);
108: goto top;
109: }
110: else if( (lt==TYREAL && rt==TYCOMPLEX) ||
111: (lt==TYCOMPLEX && rt==TYREAL) )
112: p->vtype = TYCOMPLEX;
113: else if( (lt==TYLREAL && rt==TYCOMPLEX) ||
114: (lt==TYCOMPLEX && rt==TYLREAL) )
115: p->vtype = TYLCOMPLEX;
116: else {
117: exprerr("mixed mode", CNULL);
118: goto err;
119: }
120:
121: if( (o==OPPLUS||o==OPSTAR) && l->tag==TCONST && r->tag!=TCONST )
122: {
123: p->leftp = r;
124: p->rightp = l;
125: }
126:
127: if(o==OPPLUS && l->tag==TNEGOP &&
128: (r->tag!=TCONST || ((struct headbits *)l->leftp)->tag==TCONST) )
129: {
130: p->subtype = OPMINUS;
131: p->leftp = r;
132: p->rightp = l->leftp;
133: }
134:
135: break;
136:
137: case TRELOP:
138: ckdcl(l);
139: ckdcl(r);
140: p->vtype = TYLOG;
141: lt = l->vtype;
142: rt = r->vtype;
143: if(lt==TYCHAR || rt==TYCHAR)
144: {
145: if(l->vtype != r->vtype)
146: {
147: exprerr("comparison of character and noncharacter data",CNULL);
148: goto err;
149: }
150: ll = conval(l->vtypep);
151: rl = conval(r->vtypep);
152: if( (o==OPEQ || o==OPNE) &&
153: ( (ll==1 && rl==1 && tailor.charcomp==1)
154: || (ll<=tailor.ftnchwd && rl<=tailor.ftnchwd
155: && tailor.charcomp==2) ))
156: {
157: if(l->tag == TCONST)
158: {
159: q = cpexpr( mkchcon(l->leftp) );
160: frexpr(l);
161: l = q;
162: }
163: if(r->tag == TCONST)
164: {
165: q = cpexpr( mkchcon(r->leftp) );
166: frexpr(r);
167: r = q;
168: }
169: if(l->vsubs == 0)
170: l->vsubs = mksub1();
171: if(r->vsubs == 0)
172: r->vsubs = mksub1();
173: p->leftp = l;
174: p->rightp = r;
175: }
176: else {
177: p->leftp = mkcall(builtin(TYINT,"ef1cmc"), arg4(l,r));
178: p->rightp = mkint(0);
179: }
180: }
181:
182: else if(lt==TYLOG || rt==TYLOG)
183: exprerr("relational involving logicals", CNULL);
184: else if( (lt==TYCOMPLEX || rt==TYCOMPLEX) &&
185: o!=OPEQ && o!=OPNE)
186: exprerr("order comparison of complex numbers", CNULL);
187: else if(lt != rt)
188: {
189: if(lt==TYINT)
190: p->leftp = coerce(rt, l);
191: else if(rt == TYINT)
192: p->rightp = coerce(lt, r);
193: }
194: break;
195:
196: case TLOGOP:
197: ckdcl(l);
198: ckdcl(r);
199: if(r->vtype != TYLOG)
200: {
201: exprerr("non-logical operand of logical operator",CNULL);
202: goto err;
203: }
204: case TNOTOP:
205: ckdcl(l);
206: if(l->vtype != TYLOG)
207: {
208: exprerr("non-logical operand of logical operator",CNULL);
209: }
210: p->vtype = TYLOG;
211: break;
212:
213: case TNEGOP:
214: ckdcl(l);
215: lt = l->vtype;
216: if(lt!=TYINT && lt!=TYREAL && lt!=TYLREAL && lt!=TYCOMPLEX)
217: {
218: exprerr("impossible unary + or - operation",CNULL);
219: goto err;
220: }
221: p->vtype = lt;
222: break;
223:
224: case TCALL:
225: p->vtype = l->vtype;
226: p->vtypep = l->vtypep;
227: break;
228:
229: case TASGNOP:
230: ckdcl(l);
231: ckdcl(r);
232: lt = l->vtype;
233: if(lt==TYFIELD)
234: lt = TYINT;
235: rt = r->vtype;
236: if(lt==TYCHAR || rt==TYCHAR || lt==TYLOG || rt==TYLOG)
237: {
238: if(lt != rt)
239: {
240: exprerr("illegal assignment",CNULL);
241: goto err;
242: }
243: }
244: else if(lt==TYSTRUCT || rt==TYSTRUCT)
245: {
246: if(lt!=rt || ((struct typeblock *)l->vtypep)->strsize!=((struct typeblock *)r->vtypep)->strsize
247: || ((struct typeblock *)l->vtypep)->stralign!=((struct typeblock *)r->vtypep)->stralign)
248: {
249: exprerr("illegal structure assignment",CNULL);
250: goto err;
251: }
252: }
253: else if ( (lt==TYCOMPLEX || rt==TYCOMPLEX) && lt!=rt)
254: /* p->rightp = r = coerce(lt, r) */ ;
255:
256: p->vtype = lt;
257: p->vtypep = l->vtypep;
258: break;
259:
260: case TCONST:
261: case TLIST:
262: case TREPOP:
263: break;
264:
265: default:
266: badtag("mknode", t);
267: }
268:
269: return((int *)p);
270:
271: err: frexpr(p);
272: return( errnode() );
273: }
274:
275:
276:
277: ckdcl(p)
278: ptr p;
279: {
280: if(p->vtype==TYUNDEFINED || (p->tag==TNAME&&p->vdcldone==0&&p->vadjdim==0))
281: {
282: /*debug*/ printf("tag=%d, typed=%d\n", p->tag, p->vtype);
283: fatal("untyped subexpression");
284: }
285: if(p->tag==TNAME) setvproc(p,PROCNO);
286: }
287:
288: ptr mkvar(p)
289: register ptr p;
290: {
291: register ptr q;
292:
293: TEST fprintf(diagfile, "mkvar(%s), blk %d\n", p->namep, blklevel);
294:
295: if(p->blklevel > blklevel)
296: p->blklevel = blklevel;
297:
298: if(p->tag == TLABEL)
299: {
300: laberr("attempt to use label as variable", p->namep);
301: return( errnode() );
302: }
303: if(instruct || p->varp==0 || ((struct headbits *)p->varp)->blklevel<blklevel)
304: {
305: q = allexpblock();
306: q->tag = TNAME;
307: q->sthead = p;
308: q->blklevel = blklevel;
309: if(! instruct)
310: ++ndecl[blklevel];
311: }
312: else q = p->varp;
313:
314: if(!instruct)
315: {
316: if(p->varp && ((struct headbits *)p->varp)->blklevel<blklevel)
317: hide(p);
318: if(p->varp == 0)
319: p->varp = q;
320: }
321:
322: p->tag = TNAME;
323: return(q);
324: }
325:
326:
327: ptr mkstruct(v,s)
328: register ptr v;
329: ptr s;
330: {
331: register ptr p;
332:
333: p = (int *)ALLOC(typeblock);
334: p->sthead = v;
335: p->tag = TSTRUCT;
336: p->blklevel = blklevel;
337: p->strdesc = s;
338: offsets(p);
339: if(v) {
340: v->blklevel = blklevel;
341: ++ndecl[blklevel];
342: v->varp = p;
343: }
344: else temptypelist = mkchain(p, temptypelist);
345: return(p);
346: }
347:
348:
349: ptr mkcall(fn1, args)
350: ptr fn1, args;
351: {
352: int i, j, first;
353: register ptr funct, p, q;
354: ptr r;
355:
356: if(fn1->tag == TERROR)
357: return( errnode() );
358: else if(fn1->tag == TNAME)
359: {
360: funct = ((struct stentry *)fn1->sthead)->varp;
361: frexpblock(fn1);
362: }
363: else
364: funct = fn1;
365: if(funct->vclass!=0 && funct->vclass!=CLARG)
366: {
367: exprerr("invalid invocation of %s",((struct stentry *)funct->sthead)->namep);
368: frexpr(args);
369: return( errnode() );
370: }
371: else extname(funct);
372:
373: if(args) for(p = args->leftp; p ; p = p->nextp)
374: {
375: q = p->datap;
376: if( (q->tag==TCALL&&q->vtype==TYUNDEFINED) ||
377: (q->tag==TNAME&&q->vdcldone==0) )
378: dclit(q);
379: if(q->tag==TNAME && q->vproc==PROCUNKNOWN)
380: setvproc(q, PROCNO);
381: if( q->vtype == TYSTRUCT)
382: {
383: first = 1;
384: for(i = 0; i<NFTNTYPES ; ++i)
385: if(q->vbase[i] != 0)
386: {
387: r = cpexpr(q);
388: if(first)
389: {
390: p->datap = r;
391: first = 0;
392: }
393: else p = p->nextp = (int *)mkchain(r, p->nextp);
394: r->vtype = ftnefl[i];
395: for(j=0; j<NFTNTYPES; ++j)
396: if(i != j) r->vbase[j] = 0;
397: }
398: frexpblock(q);
399: }
400: }
401:
402: return( mknode(TCALL,0,cpexpr(funct), args) );
403: }
404:
405:
406:
407: mkcase(p,here)
408: ptr p;
409: int here;
410: {
411: register ptr q, s;
412:
413: for(s = thisctl ; s!=0 && s->subtype!=STSWITCH ; s = s->prevctl)
414: ;
415: if(s==0 || (here && s!=thisctl) )
416: {
417: laberr("invalid case label location",CNULL);
418: return(0);
419: }
420:
421: p = simple(RVAL,p);
422: for(q = s->loopctl ; q!=0 && !eqcon(p,q->casexpr) ; q = q->nextcase)
423: ;
424: if(q == 0)
425: {
426: q = (int *)ALLOC(caseblock);
427: q->tag = TCASE;
428: q->casexpr = p;
429: q->labelno = ( here ? thislab() : nextlab() );
430: q->nextcase = s->loopctl;
431: s->loopctl = q;
432: }
433: else if(here)
434: if(thisexec->labelno == 0)
435: thisexec->labelno = q->labelno;
436: else if(thisexec->labelno != q->labelno)
437: {
438: exnull();
439: thisexec->labelno = q->labelno;
440: thisexec->labused = 0;
441: }
442: if(here)
443: if(q->labdefined)
444: laberr("multiply defined case",CNULL);
445: else
446: q->labdefined = 1;
447: return(q->labelno);
448: }
449:
450:
451: ptr mkilab(p)
452: ptr p;
453: {
454: char *s, l[30];
455:
456: if(p->tag!=TCONST || p->vtype!=TYINT)
457: {
458: execerr("invalid label","");
459: s = "";
460: }
461: else s = (char *)p->leftp;
462:
463: while(*s == '0')
464: ++s;
465: sprintf(l,"#%s", s);
466:
467:
468: TEST fprintf(diagfile,"numeric label = %s\n", l);
469: return( mkname(l) );
470: }
471:
472:
473:
474:
475: mklabel(p,here)
476: ptr p;
477: int here;
478: {
479: register ptr q;
480:
481: if(q = p->varp)
482: {
483: if(q->tag != TLABEL)
484: laberr("%s is already a nonlabel\n", p->namep);
485: else if(q->labinacc)
486: warn1("label %s is inaccessible", p->namep);
487: else if(here)
488: if(q->labdefined)
489: laberr("%s is already defined\n", p->namep);
490: /*
491: else if(blklevel > q->blklevel)
492: laberr("%s is illegally placed\n",p->namep);
493: */
494: /* dirty fixup for wm coughran */
495: else {
496: if(blklevel > q->blklevel)
497: labwarn("%s is illegally placed\n",p->namep);
498:
499: q->labdefined = 1;
500: if(thisexec->labelno == 0)
501: thisexec->labelno = q->labelno;
502: else if(thisexec->labelno != q->labelno)
503: {
504: exnull();
505: thisexec->labelno = q->labelno;
506: thisexec->labused = 0;
507: }
508: }
509: }
510: else {
511: q = (int *)ALLOC(labelblock);
512: p->varp = q;
513: q->tag = TLABEL;
514: q->subtype = 0;
515: q->blklevel = blklevel;
516: ++ndecl[blklevel];
517: q->labdefined = here;
518: q->labelno = ( here ? thislab() : nextlab() );
519: q->sthead = p;
520: }
521:
522: return(q->labelno);
523: }
524:
525:
526: thislab()
527: {
528: if(thisexec->labelno == 0)
529: thisexec->labelno = nextlab();
530: return(thisexec->labelno);
531: }
532:
533:
534: nextlab()
535: {
536: stnos[++labno] = 0;
537: return( labno );
538: }
539:
540:
541: nextindif()
542: {
543: if(++nxtindif < MAXINDIFS)
544: return(nxtindif);
545: fatal("too many indifs"); return 0;
546: }
547:
548:
549:
550:
551: mkkeywd(s, n)
552: char *s;
553: int n;
554: {
555: register ptr p;
556: register ptr q;
557:
558: p = (int *)name(s, 2);
559: q = (int *)ALLOC(keyblock);
560: p->tag = TKEYWORD;
561: q->tag = TKEYWORD;
562: p->subtype = n;
563: q->subtype = n;
564: p->blklevel = 0;
565: p->varp = q;
566: q->sthead = p;
567: }
568:
569:
570: ptr mkdef(s, v)
571: char *s, *v;
572: {
573: register ptr p;
574: register ptr q;
575:
576: if(p = (int *)name(s,1))
577: if(p->blklevel == 0)
578: {
579: if(blklevel > 0)
580: hide(p);
581: else if(p->tag != TDEFINE)
582: dclerr("attempt to DEFINE a variable name", s);
583: else {
584: if( strcmp(v, ((struct defblock *)(q=p->varp))->valp) )
585: {
586: warn("macro value replaced");
587: cfree(q->valp);
588: q->valp = copys(v);
589: }
590: return(p);
591: }
592: }
593: else {
594: dclerr("type already defined", s);
595: return( errnode() );
596: }
597: else p = (int *)name(s,0);
598:
599: q = (int *)ALLOC(defblock);
600: p->tag = TDEFINE;
601: q->tag = TDEFINE;
602: p->blklevel = q->blklevel = (blklevel==0 ? 0 : 1);
603: q->sthead = p;
604: p->varp = q;
605: ((struct defblock *)p->varp)->valp = copys(v);
606: return(p);
607: }
608:
609:
610:
611: mkknown(s,t)
612: char *s;
613: int t;
614: {
615: register ptr p;
616:
617: p = (int *)ALLOC(knownname);
618: p->nextfunct = knownlist;
619: p->tag = TKNOWNFUNCT;
620: knownlist = p;
621: p->funcname = s;
622: p->functype = t;
623: }
624:
625:
626:
627:
628:
629:
630:
631: ptr mkint(k)
632: int k;
633: {
634: return( mkconst(TYINT, convic(k) ) );
635: }
636:
637:
638: ptr mkconst(t,p)
639: int t;
640: ptr p;
641: {
642: ptr q;
643:
644: q = mknode(TCONST, 0, copys(p), PNULL);
645: q->vtype = t;
646: if(t == TYCHAR)
647: q->vtypep = mkint( strlen(p) );
648: return(q);
649: }
650:
651:
652:
653: ptr mkimcon(t,p)
654: int t;
655: char *p;
656: {
657: ptr q;
658: char *zero, buff[100];
659:
660: zero = (t==TYCOMPLEX ? "0." : "0d0");
661: sprintf(buff, "(%s,%s)", zero, p);
662: q = mknode(TCONST, 0, copys(buff), PNULL);
663: q->vtype = t;
664: return(q);
665: }
666:
667:
668:
669: ptr mkarrow(p,t)
670: register ptr p;
671: ptr t;
672: {
673: register ptr q, s;
674:
675: if(p->vsubs == 0)
676: if(p->vdim==0 && p->vtype!=TYCHAR && p->vtype!=TYSTRUCT)
677: {
678: exprerr("need an aggregate to the left of arrow",CNULL);
679: frexpr(p);
680: return( errnode() );
681: }
682: else {
683: if(p->vdim)
684: {
685: s = 0;
686: for(q = ((chainp)p->vdim)->datap ; q ; q = q->nextp)
687: s = (int *)mkchain( mkint(1), s);
688: subscript(p, mknode(TLIST,0,s,PNULL) );
689: }
690: }
691:
692: p->vtype = TYSTRUCT;
693: p->vtypep = t->varp;
694: return(p);
695: }
696:
697:
698:
699:
700:
701: mkequiv(p)
702: ptr p;
703: {
704: ptr q, t;
705: int first;
706:
707: swii(iefile);
708: putic(ICBEGIN, 0);
709: putic(ICINDENT, 0);
710: putic(ICKEYWORD, FEQUIVALENCE);
711: putic(ICOP, OPLPAR);
712: first = 1;
713:
714: for(q = p ; q ; q = q->nextp)
715: {
716: if(first) first = 0;
717: else putic(ICOP, OPCOMMA);
718: prexpr( t = simple(LVAL,q->datap) );
719: frexpr(t);
720: }
721:
722: putic(ICOP, OPRPAR);
723: swii(icfile);
724: frchain( &p );
725: }
726:
727:
728:
729:
730: mkgeneric(gname,atype,fname,ftype)
731: char *gname, *fname;
732: int atype, ftype;
733: {
734: register ptr p;
735: ptr generic();
736:
737: if(p = generic(gname))
738: {
739: if(p->genfname[atype])
740: fatal1("generic name already defined", gname);
741: }
742: else {
743: p = (int *)ALLOC(genblock);
744: p->tag = TGENERIC;
745: p->nextgenf = generlist;
746: generlist = p;
747: p->genname = gname;
748: }
749:
750: p->genfname[atype] = fname;
751: p->genftype[atype] = ftype;
752: }
753:
754:
755: ptr generic(s)
756: char *s;
757: {
758: register ptr p;
759:
760: for(p= generlist; p ; p = p->nextgenf)
761: if(equals(s, p->genname))
762: return(p);
763: return(0);
764: }
765:
766:
767: knownfunct(s)
768: char *s;
769: {
770: register ptr p;
771:
772: for(p = knownlist ; p ; p = p->nextfunct)
773: if(equals(s, p->funcname))
774: return(p->functype);
775: return(0);
776: }
777:
778:
779:
780:
781:
782: ptr funcinv(p)
783: register ptr p;
784: {
785: ptr fp, fp1;
786: register ptr g;
787: char *s;
788: register int t;
789: int vt;
790:
791: if(g = generic(s = ((struct stentry *)((struct typeblock *)p->leftp)->sthead)->namep))
792: {
793: if(((struct headbits *)p->rightp)->tag==TLIST && ((struct exprblock *)p->rightp)->leftp
794: && ( (vt = typearg(((struct exprblock *)p->rightp)->leftp)) >=0)
795: && (t = g->genftype[vt]) )
796: {
797: p->leftp = builtin(t, g->genfname[vt]);
798: }
799: else {
800: dclerr("improper use of generic function", s);
801: frexpr(p);
802: return( errnode() );
803: }
804: }
805:
806: fp = p->leftp;
807: setvproc(fp, PROCYES);
808: fp1 = ((struct stentry *)fp->sthead)->varp;
809: s = ((struct stentry *)fp->sthead)->namep;
810:
811: if(p->vtype==TYUNDEFINED && fp->vclass!=CLARG)
812: if(t = knownfunct(s))
813: {
814: p->vtype = t;
815: setvproc(fp, PROCINTRINSIC);
816: setvproc(fp1, PROCINTRINSIC);
817: fp1->vtype = t;
818: builtin(t,((struct stentry *)fp1->sthead)->namep);
819: cpblock(fp1, fp, sizeof(struct exprblock));
820: }
821:
822: dclit(p);
823: return(p);
824: }
825:
826:
827:
828:
829: typearg(p0)
830: register chainp p0;
831: {
832: register chainp p;
833: register int vt, maxt;
834:
835: if(p0 == NULL)
836: return(-1);
837: maxt = ((struct exprblock *)p0->datap)->vtype;
838:
839: for(p = (chainp)p0->nextp ; p ; p = (chainp)p->nextp)
840: if( (vt = ((struct exprblock *)p->datap)->vtype) > maxt)
841: maxt = vt;
842:
843: for(p = p0 ; p ; p = (chainp)p->nextp)
844: p->datap = coerce(maxt, p->datap);
845:
846: return(maxt);
847: }
848:
849:
850:
851:
852: ptr typexpr(t,e)
853: register ptr t, e;
854: {
855: ptr e1;
856: int etag;
857:
858: if(t->atdim!=0 || (e->tag==TLIST && t->attype!=TYCOMPLEX) )
859: goto typerr;
860:
861: switch(t->attype)
862: {
863: case TYCOMPLEX:
864: if(e->tag==TLIST)
865: if(e->leftp==0 || ((chainp)e->leftp)->nextp==0
866: || ((chainp)((chainp)e->leftp)->nextp)->nextp!=0)
867: {
868: exprerr("bad conversion to complex", "");
869: return( errnode() );
870: }
871: else {
872: ((chainp)e->leftp)->datap = simple(RVAL,
873: ((chainp)e->leftp)->datap);
874: ((chainp)((chainp)e->leftp)->nextp)->datap = simple(RVAL,
875: ((chainp)((chainp)e->leftp)->nextp)->datap);
876: if(isconst(((chainp)e->leftp)->datap) &&
877: isconst(((chainp)((chainp)e->leftp)->nextp)->datap) )
878: return( compconst(e) );
879: e1 = mkcall(builtin(TYCOMPLEX,"cmplx"),
880: arg2( coerce(TYREAL,((chainp)e->leftp)->datap),
881: coerce(TYREAL,((chainp)((chainp)e->leftp)->nextp)->datap)));
882: frchain( &(e->leftp) );
883: frexpblock(e);
884: return(e1);
885: }
886:
887: case TYINT:
888: case TYREAL:
889: case TYLREAL:
890: case TYLOG:
891: case TYFIELD:
892: e = coerce(t->attype, simple(RVAL, e) );
893: etag = e->tag;
894: if(etag==TAROP || etag==TLOGOP || etag==TRELOP)
895: e->needpar = YES;
896: return(e);
897:
898: case TYCHAR:
899: case TYSTRUCT:
900: goto typerr;
901: }
902:
903: typerr:
904: exprerr("typexpr not fully implemented", "");
905: frexpr(e);
906: return( errnode() );
907: }
908:
909:
910:
911:
912: ptr compconst(p)
913: register ptr p;
914: {
915: register ptr a, b;
916: int as, bs;
917: int prec;
918:
919: prec = TYREAL;
920: p = p->leftp;
921: if(p == 0)
922: goto err;
923: if(((struct exprblock *)p->datap)->vtype == TYLREAL)
924: prec = TYLREAL;
925: a = coerce(TYLREAL, p->datap);
926: p = p->nextp;
927: if(p->nextp)
928: goto err;
929: if(((struct exprblock *)p->datap)->vtype == TYLREAL)
930: a = coerce(prec = TYLREAL,a);
931: b = coerce(TYLREAL, p->datap);
932:
933: if(a->tag==TNEGOP)
934: {
935: as = '-';
936: a = a->leftp;
937: }
938: else as = ' ';
939:
940: if(b->tag==TNEGOP)
941: {
942: bs = '-';
943: b = b->leftp;
944: }
945: else bs = ' ';
946:
947: if(a->tag!=TCONST || a->vtype!=prec ||
948: b->tag!=TCONST || b->vtype!=prec )
949: goto err;
950:
951: if(prec==TYLREAL && tailor.lngcxtype==NULL)
952: {
953: ptr q, e1, e2;
954: struct dimblock *dp;
955: sprintf(msg, "_const%d", ++constno);
956: q = mkvar(mkname(msg));
957: q->vtype = TYLREAL;
958: dclit(q);
959: dp = ALLOC(dimblock);
960: dp->upperb = mkint(2);
961: q->vdim = (int *)mkchain(dp,CHNULL);
962: sprintf(msg, "%c%s", as, a->leftp);
963: e1 = mkconst(TYLREAL, msg);
964: sprintf(msg, "%c%s", bs, b->leftp);
965: e2 = mkconst(TYLREAL, msg);
966: mkinit(q, mknode(TLIST,0, mkchain(e1,mkchain(e2,CHNULL)),PNULL) );
967: cfree(q->vdim);
968: q->vtype = TYLCOMPLEX;
969: return(q);
970: }
971: else
972: {
973: sprintf(msg, "(%c%s, %c%s)", as, a->leftp, bs, b->leftp);
974: return( mkconst(TYCOMPLEX, msg) );
975: }
976:
977: err: exprerr("invalid complex constant", "");
978: return( errnode() );
979: }
980:
981:
982:
983:
984: ptr mkchcon(p)
985: char *p;
986: {
987: register ptr q;
988: char buf[10];
989:
990: sprintf(buf, "_const%d", ++constno);
991: q = mkvar(mkname(buf));
992: q->vtype = TYCHAR;
993: q->vtypep = mkint(strlen(p));
994: mkinit(q, mkconst(TYCHAR, p));
995: return(q);
996: }
997:
998:
999:
1000: ptr mksub1()
1001: {
1002: return( mknode(TLIST,0, mkchain(mkint(1),CHNULL), PNULL) );
1003: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.