![[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 [CSRG BSD Unix] / 40BSD / cmd / efl|
Return to mk.c CVS log | Up to [CSRG BSD Unix] / 40BSD / 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 = commonlist ; p ; p = p->nextp)
11: if(equals(s, p->datap->comname))
12: return(p->datap);
13:
14: p = 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 = name(s,1)) == 0)
32: {
33: p = 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 = 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 || 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 || l->vtypep->strsize!=r->vtypep->strsize
247: || l->vtypep->stralign!=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(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(instruct || p->varp==0 || p->varp->blklevel<blklevel)
299: {
300: q = allexpblock();
301: q->tag = TNAME;
302: q->sthead = p;
303: q->blklevel = blklevel;
304: if(! instruct)
305: ++ndecl[blklevel];
306: }
307: else q = p->varp;
308:
309: if(!instruct)
310: {
311: if(p->varp && p->varp->blklevel<blklevel)
312: hide(p);
313: if(p->varp == 0)
314: p->varp = q;
315: }
316:
317: p->tag = TNAME;
318: return(q);
319: }
320:
321:
322: ptr mkstruct(v,s)
323: register ptr v;
324: ptr s;
325: {
326: register ptr p;
327:
328: p = ALLOC(typeblock);
329: p->sthead = v;
330: p->tag = TSTRUCT;
331: p->blklevel = blklevel;
332: p->strdesc = s;
333: offsets(p);
334: if(v) {
335: v->blklevel = blklevel;
336: ++ndecl[blklevel];
337: v->varp = p;
338: }
339: else temptypelist = mkchain(p, temptypelist);
340: return(p);
341: }
342:
343:
344: ptr mkcall(fn1, args)
345: ptr fn1, args;
346: {
347: int i, j, first;
348: register ptr funct, p, q;
349: ptr r;
350:
351: if(fn1->tag == TERROR)
352: return( errnode() );
353: else if(fn1->tag == TNAME)
354: {
355: funct = fn1->sthead->varp;
356: frexpblock(fn1);
357: }
358: else
359: funct = fn1;
360: if(funct->vclass!=0 && funct->vclass!=CLARG)
361: {
362: exprerr("invalid invocation of %s",funct->sthead->namep);
363: frexpr(args);
364: return( errnode() );
365: }
366: else extname(funct);
367:
368: if(args) for(p = args->leftp; p ; p = p->nextp)
369: {
370: q = p->datap;
371: if( (q->tag==TCALL&&q->vtype==TYUNDEFINED) ||
372: (q->tag==TNAME&&q->vdcldone==0) )
373: dclit(q);
374: if(q->tag==TNAME && q->vproc==PROCUNKNOWN)
375: setvproc(q, PROCNO);
376: if( q->vtype == TYSTRUCT)
377: {
378: first = 1;
379: for(i = 0; i<NFTNTYPES ; ++i)
380: if(q->vbase[i] != 0)
381: {
382: r = cpexpr(q);
383: if(first)
384: {
385: p->datap = r;
386: first = 0;
387: }
388: else p = p->nextp = mkchain(r, p->nextp);
389: r->vtype = ftnefl[i];
390: for(j=0; j<NFTNTYPES; ++j)
391: if(i != j) r->vbase[j] = 0;
392: }
393: frexpblock(q);
394: }
395: }
396:
397: return( mknode(TCALL,0,cpexpr(funct), args) );
398: }
399:
400:
401:
402: mkcase(p,here)
403: ptr p;
404: int here;
405: {
406: register ptr q, s;
407:
408: for(s = thisctl ; s!=0 && s->subtype!=STSWITCH ; s = s->prevctl)
409: ;
410: if(s==0 || (here && s!=thisctl) )
411: {
412: laberr("invalid case label location",CNULL);
413: return(0);
414: }
415: for(q = s->loopctl ; q!=0 && !eqcon(p,q->casexpr) ; q = q->nextcase)
416: ;
417: if(q == 0)
418: {
419: q = ALLOC(caseblock);
420: q->tag = TCASE;
421: q->casexpr = p;
422: q->labelno = ( here ? thislab() : nextlab() );
423: q->nextcase = s->loopctl;
424: s->loopctl = q;
425: }
426: else if(here)
427: if(thisexec->labelno == 0)
428: thisexec->labelno = q->labelno;
429: else if(thisexec->labelno != q->labelno)
430: {
431: exnull();
432: thisexec->labelno = q->labelno;
433: thisexec->labused = 0;
434: }
435: if(here)
436: if(q->labdefined)
437: laberr("multiply defined case",CNULL);
438: else
439: q->labdefined = 1;
440: return(q->labelno);
441: }
442:
443:
444: ptr mkilab(p)
445: ptr p;
446: {
447: char *s, l[30];
448:
449: if(p->tag!=TCONST || p->vtype!=TYINT)
450: {
451: execerr("invalid label","");
452: s = "";
453: }
454: else s = p->leftp;
455:
456: while(*s == '0')
457: ++s;
458: sprintf(l,"#%s", s);
459:
460:
461: TEST fprintf(diagfile,"numeric label = %s\n", l);
462: return( mkname(l) );
463: }
464:
465:
466:
467:
468: mklabel(p,here)
469: ptr p;
470: int here;
471: {
472: register ptr q;
473:
474: if(q = p->varp)
475: {
476: if(q->tag != TLABEL)
477: laberr("%s is already a nonlabel\n", p->namep);
478: else if(q->labinacc)
479: warn1("label %s is inaccessible", p->namep);
480: else if(here)
481: if(q->labdefined)
482: laberr("%s is already defined\n", p->namep);
483: else if(blklevel > q->blklevel)
484: laberr("%s is illegally placed\n",p->namep);
485: else {
486: q->labdefined = 1;
487: if(thisexec->labelno == 0)
488: thisexec->labelno = q->labelno;
489: else if(thisexec->labelno != q->labelno)
490: {
491: exnull();
492: thisexec->labelno = q->labelno;
493: thisexec->labused = 0;
494: }
495: }
496: }
497: else {
498: q = ALLOC(labelblock);
499: p->varp = q;
500: q->tag = TLABEL;
501: q->subtype = 0;
502: q->blklevel = blklevel;
503: ++ndecl[blklevel];
504: q->labdefined = here;
505: q->labelno = ( here ? thislab() : nextlab() );
506: q->sthead = p;
507: }
508:
509: return(q->labelno);
510: }
511:
512:
513: thislab()
514: {
515: if(thisexec->labelno == 0)
516: thisexec->labelno = nextlab();
517: return(thisexec->labelno);
518: }
519:
520:
521: nextlab()
522: {
523: stnos[++labno] = 0;
524: return( labno );
525: }
526:
527:
528: nextindif()
529: {
530: if(++nxtindif < MAXINDIFS)
531: return(nxtindif);
532: fatal("too many indifs");
533: }
534:
535:
536:
537:
538: mkkeywd(s, n)
539: char *s;
540: int n;
541: {
542: register ptr p;
543: register ptr q;
544:
545: p = name(s, 2);
546: q = ALLOC(keyblock);
547: p->tag = TKEYWORD;
548: q->tag = TKEYWORD;
549: p->subtype = n;
550: q->subtype = n;
551: p->blklevel = 0;
552: p->varp = q;
553: q->sthead = p;
554: }
555:
556:
557: ptr mkdef(s, v)
558: char *s, *v;
559: {
560: register ptr p;
561: register ptr q;
562:
563: if(p = name(s,1))
564: if(p->blklevel == 0)
565: {
566: if(blklevel > 0)
567: hide(p);
568: else if(p->tag != TDEFINE)
569: dclerr("attempt to DEFINE a variable name", s);
570: else {
571: if( strcmp(v, (q=p->varp) ->valp) )
572: {
573: warn("macro value replaced");
574: cfree(q->valp);
575: q->valp = copys(v);
576: }
577: return(p);
578: }
579: }
580: else {
581: dclerr("type already defined", s);
582: return( errnode() );
583: }
584: else p = name(s,0);
585:
586: q = ALLOC(defblock);
587: p->tag = TDEFINE;
588: q->tag = TDEFINE;
589: p->blklevel = q->blklevel = (blklevel==0 ? 0 : 1);
590: q->sthead = p;
591: p->varp = q;
592: p->varp->valp = copys(v);
593: return(p);
594: }
595:
596:
597:
598: mkknown(s,t)
599: char *s;
600: int t;
601: {
602: register ptr p;
603:
604: p = ALLOC(knownname);
605: p->nextfunct = knownlist;
606: p->tag = TKNOWNFUNCT;
607: knownlist = p;
608: p->funcname = s;
609: p->functype = t;
610: }
611:
612:
613:
614:
615:
616:
617:
618: ptr mkint(k)
619: int k;
620: {
621: return( mkconst(TYINT, convic(k) ) );
622: }
623:
624:
625: ptr mkconst(t,p)
626: int t;
627: ptr p;
628: {
629: ptr q;
630:
631: q = mknode(TCONST, 0, copys(p), PNULL);
632: q->vtype = t;
633: if(t == TYCHAR)
634: q->vtypep = mkint( strlen(p) );
635: return(q);
636: }
637:
638:
639:
640: ptr mkimcon(t,p)
641: int t;
642: char *p;
643: {
644: ptr q;
645: char *zero, buff[100];
646:
647: zero = (t==TYCOMPLEX ? "0." : "0d0");
648: sprintf(buff, "(%s,%s)", zero, p);
649: q = mknode(TCONST, 0, copys(buff), PNULL);
650: q->vtype = t;
651: return(q);
652: }
653:
654:
655:
656: ptr mkarrow(p,t)
657: register ptr p;
658: ptr t;
659: {
660: register ptr q, s;
661:
662: if(p->vsubs == 0)
663: if(p->vdim==0 && p->vtype!=TYCHAR && p->vtype!=TYSTRUCT)
664: {
665: exprerr("need an aggregate to the left of arrow",CNULL);
666: frexpr(p);
667: return( errnode() );
668: }
669: else {
670: if(p->vdim)
671: {
672: s = 0;
673: for(q = p->vdim->datap ; q ; q = q->nextp)
674: s = mkchain( mkint(1), s);
675: subscript(p, mknode(TLIST,0,s,PNULL) );
676: }
677: }
678:
679: p->vtype = TYSTRUCT;
680: p->vtypep = t->varp;
681: return(p);
682: }
683:
684:
685:
686:
687:
688: mkequiv(p)
689: ptr p;
690: {
691: ptr q, t;
692: int first;
693:
694: swii(iefile);
695: putic(ICBEGIN, 0);
696: putic(ICINDENT, 0);
697: putic(ICKEYWORD, FEQUIVALENCE);
698: putic(ICOP, OPLPAR);
699: first = 1;
700:
701: for(q = p ; q ; q = q->nextp)
702: {
703: if(first) first = 0;
704: else putic(ICOP, OPCOMMA);
705: prexpr( t = simple(LVAL,q->datap) );
706: frexpr(t);
707: }
708:
709: putic(ICOP, OPRPAR);
710: swii(icfile);
711: frchain( &p );
712: }
713:
714:
715:
716:
717: mkgeneric(gname,atype,fname,ftype)
718: char *gname, *fname;
719: int atype, ftype;
720: {
721: register ptr p;
722: ptr generic();
723:
724: if(p = generic(gname))
725: {
726: if(p->genfname[atype])
727: fatal1("generic name already defined", gname);
728: }
729: else {
730: p = ALLOC(genblock);
731: p->tag = TGENERIC;
732: p->nextgenf = generlist;
733: generlist = p;
734: p->genname = gname;
735: }
736:
737: p->genfname[atype] = fname;
738: p->genftype[atype] = ftype;
739: }
740:
741:
742: ptr generic(s)
743: char *s;
744: {
745: register ptr p;
746:
747: for(p= generlist; p ; p = p->nextgenf)
748: if(equals(s, p->genname))
749: return(p);
750: return(0);
751: }
752:
753:
754: knownfunct(s)
755: char *s;
756: {
757: register ptr p;
758:
759: for(p = knownlist ; p ; p = p->nextfunct)
760: if(equals(s, p->funcname))
761: return(p->functype);
762: return(0);
763: }
764:
765:
766:
767:
768:
769: ptr funcinv(p)
770: register ptr p;
771: {
772: ptr fp, fp1;
773: register ptr g;
774: char *s;
775: register int t;
776: int vt;
777:
778: if(g = generic(s = p->leftp->sthead->namep))
779: {
780: if(p->rightp->tag==TLIST && p->rightp->leftp
781: && ( (vt = typearg(p->rightp->leftp)) >=0)
782: && (t = g->genftype[vt]) )
783: {
784: p->leftp = builtin(t, g->genfname[vt]);
785: }
786: else {
787: dclerr("improper use of generic function", s);
788: frexpr(p);
789: return( errnode() );
790: }
791: }
792:
793: fp = p->leftp;
794: setvproc(fp, PROCYES);
795: fp1 = fp->sthead->varp;
796: s = fp->sthead->namep;
797:
798: if(p->vtype==TYUNDEFINED && fp->vclass!=CLARG)
799: if(t = knownfunct(s))
800: {
801: p->vtype = t;
802: setvproc(fp, PROCINTRINSIC);
803: setvproc(fp1, PROCINTRINSIC);
804: fp1->vtype = t;
805: builtin(t,fp1->sthead->namep);
806: cpblock(fp1, fp, sizeof(struct exprblock));
807: }
808:
809: dclit(p);
810: return(p);
811: }
812:
813:
814:
815:
816: typearg(p0)
817: register chainp p0;
818: {
819: register chainp p;
820: register int vt, maxt;
821:
822: if(p0 == NULL)
823: return(-1);
824: maxt = p0->datap->vtype;
825:
826: for(p = p0->nextp ; p ; p = p->nextp)
827: if( (vt = p->datap->vtype) > maxt)
828: maxt = vt;
829:
830: for(p = p0 ; p ; p = p->nextp)
831: p->datap = coerce(maxt, p->datap);
832:
833: return(maxt);
834: }
835:
836:
837:
838:
839: ptr typexpr(t,e)
840: register ptr t, e;
841: {
842: ptr e1;
843: int etag;
844:
845: if(t->atdim!=0 || (e->tag==TLIST && t->attype!=TYCOMPLEX) )
846: goto typerr;
847:
848: switch(t->attype)
849: {
850: case TYCOMPLEX:
851: if(e->tag==TLIST)
852: if(e->leftp==0 || e->leftp->nextp==0
853: || e->leftp->nextp->nextp!=0)
854: {
855: exprerr("bad conversion to complex", "");
856: return( errnode() );
857: }
858: else {
859: e->leftp->datap = simple(RVAL,
860: e->leftp->datap);
861: e->leftp->nextp->datap = simple(RVAL,
862: e->leftp->nextp->datap);
863: if(isconst(e->leftp->datap) &&
864: isconst(e->leftp->nextp->datap) )
865: return( compconst(e) );
866: e1 = mkcall(builtin(TYCOMPLEX,"cmplx"),
867: arg2( coerce(TYREAL,e->leftp->datap),
868: coerce(TYREAL,e->leftp->nextp->datap)));
869: frchain( &(e->leftp) );
870: frexpblock(e);
871: return(e1);
872: }
873:
874: case TYINT:
875: case TYREAL:
876: case TYLREAL:
877: case TYLOG:
878: case TYFIELD:
879: e = coerce(t->attype, simple(RVAL, e) );
880: etag = e->tag;
881: if(etag==TAROP || etag==TLOGOP || etag==TRELOP)
882: e->needpar = YES;
883: return(e);
884:
885: case TYCHAR:
886: case TYSTRUCT:
887: goto typerr;
888: }
889:
890: typerr:
891: exprerr("typexpr not fully implemented", "");
892: frexpr(e);
893: return( errnode() );
894: }
895:
896:
897:
898:
899: ptr compconst(p)
900: register ptr p;
901: {
902: register ptr a, b;
903: int as, bs;
904: int prec;
905:
906: prec = TYREAL;
907: p = p->leftp;
908: if(p == 0)
909: goto err;
910: if(p->datap->vtype == TYLREAL)
911: prec = TYLREAL;
912: a = coerce(TYLREAL, p->datap);
913: p = p->nextp;
914: if(p->nextp)
915: goto err;
916: if(p->datap->vtype == TYLREAL)
917: a = coerce(prec = TYLREAL,a);
918: b = coerce(TYLREAL, p->datap);
919:
920: if(a->tag==TNEGOP)
921: {
922: as = '-';
923: a = a->leftp;
924: }
925: else as = ' ';
926:
927: if(b->tag==TNEGOP)
928: {
929: bs = '-';
930: b = b->leftp;
931: }
932: else bs = ' ';
933:
934: if(a->tag!=TCONST || a->vtype!=prec ||
935: b->tag!=TCONST || b->vtype!=prec )
936: goto err;
937:
938: if(prec==TYLREAL && tailor.lngcxtype==NULL)
939: {
940: ptr q, e1, e2;
941: struct dimblock *dp;
942: sprintf(msg, "_const%d", ++constno);
943: q = mkvar(mkname(msg));
944: q->vtype = TYLREAL;
945: dclit(q);
946: dp = ALLOC(dimblock);
947: dp->upperb = mkint(2);
948: q->vdim = mkchain(dp,CHNULL);
949: sprintf(msg, "%c%s", as, a->leftp);
950: e1 = mkconst(TYLREAL, msg);
951: sprintf(msg, "%c%s", bs, b->leftp);
952: e2 = mkconst(TYLREAL, msg);
953: mkinit(q, mknode(TLIST,0, mkchain(e1,mkchain(e2,CHNULL)),PNULL) );
954: cfree(q->vdim);
955: q->vtype = TYLCOMPLEX;
956: return(q);
957: }
958: else
959: {
960: sprintf(msg, "(%c%s, %c%s)", as, a->leftp, bs, b->leftp);
961: return( mkconst(TYCOMPLEX, msg) );
962: }
963:
964: err: exprerr("invalid complex constant", "");
965: return( errnode() );
966: }
967:
968:
969:
970:
971: ptr mkchcon(p)
972: char *p;
973: {
974: register ptr q;
975: char buf[10];
976:
977: sprintf(buf, "_const%d", ++constno);
978: q = mkvar(mkname(buf));
979: q->vtype = TYCHAR;
980: q->vtypep = mkint(strlen(p));
981: mkinit(q, mkconst(TYCHAR, p));
982: return(q);
983: }
984:
985:
986:
987: ptr mksub1()
988: {
989: return( mknode(TLIST,0, mkchain(mkint(1),CHNULL), PNULL) );
990: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.