![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to vax.c CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Research Unix] / researchv10dc / cmd / f77|
Return to vax.c CVS log | Up to [Research Unix] / researchv10dc / cmd / f77 |
1.1 root 1: #include "defs"
2:
3: #ifdef SDB
4: # include <a.out.h>
5: extern int types2[];
6: # ifndef N_SO
7: # include <stab.h>
8: # endif
9: #endif
10:
11: #include "pccdefs"
12:
13: /*
14: VAX-11/780 - SPECIFIC ROUTINES
15: */
16:
17:
18: int maxregvar = MAXREGVAR;
19: int regnum[] = {
20: 11, 10, 9, 8, 7, 6 };
21: static int regmask[] = {
22: 0, 0x800, 0xc00, 0xe00, 0xf00, 0xf80, 0xfc0 };
23:
24:
25:
26: ftnint intcon[14] =
27: {
28: 2, 2, 2, 2,
29: 15, 31, 24, 56,
30: -128, -128, 127, 127,
31: 32767, 2147483647 };
32:
33: #if HERE == VAX
34: /* then put in constants in octal */
35: long realcon[6][2] =
36: {
37: { 0200, 0 },
38: { 0200, 0 },
39: { 037777677777, 0 },
40: { 037777677777, 037777777777 },
41: { 032200, 0 },
42: { 022200, 0 }
43: };
44:
45: #else
46: double realcon[6] =
47: {
48: 2.9387358771e-39,
49: 2.938735877055718800e-39
50: 1.7014117332e+38,
51: 1.701411834604692250e+38
52: 5.960464e-8,
53: 1.38777878078144567e-17,
54: };
55: #endif
56:
57:
58:
59:
60: prsave(proflab)
61: int proflab;
62: {
63: if(profileflag)
64: {
65: fprintf(asmfile, "L%d:\t.space\t4\n", proflab);
66: p2pi("\tmovab\tL%d,r0", proflab);
67: p2pass("\tjsb\tmcount");
68: }
69: p2pi("\tsubl2\t$LF%d,sp", procno);
70: }
71:
72:
73:
74: goret(type)
75: int type;
76: {
77: #ifdef SDB
78: char *stabdline();
79:
80: if (sdbflag)
81: p2pass(stabdline(N_RFUN, lineno));
82: #endif
83: p2pass("\tret");
84: }
85:
86:
87:
88:
89: /*
90: * move argument slot arg1 (relative to ap)
91: * to slot arg2 (relative to ARGREG)
92: */
93:
94: mvarg(type, arg1, arg2)
95: int type, arg1, arg2;
96: {
97: p2pij("\tmovl\t%d(ap),%d(fp)", arg1+ARGOFFSET, arg2+argloc);
98: }
99:
100:
101:
102:
103: prlabel(fp, k)
104: FILEP fp;
105: int k;
106: {
107: fprintf(fp, "L%d:\n", k);
108: }
109:
110:
111:
112: prconi(fp, type, n)
113: FILEP fp;
114: int type;
115: ftnint n;
116: {
117: fprintf(fp, "\t%s\t%ld\n", (type==TYSHORT ? ".word" : ".long"), n);
118: }
119:
120:
121:
122: prcona(fp, a)
123: FILEP fp;
124: ftnint a;
125: {
126: fprintf(fp, "\t.long\tL%ld\n", a);
127: }
128:
129:
130:
131: #ifndef vax
132: prconr(fp, type, x)
133: FILEP fp;
134: int type;
135: float x;
136: {
137: fprintf(fp, "\t%s\t0f%e\n", (type==TYREAL ? ".float" : ".double"), x);
138: }
139: #endif
140:
141: #ifdef vax
142: prconr(fp, type, x)
143: FILEP fp;
144: int type;
145: double x;
146: {
147: /* non-portable cheat to preserve bit patterns */
148: union {
149: double xd;
150: long int xl[2];
151: } cheat;
152: cheat.xd = x;
153: if(type == TYREAL)
154: {
155: float y = x;
156: fprintf(fp, "\t.long\t0x%X\n", *(long *) &y);
157: }
158: else
159: fprintf(fp, "\t.long\t0x%X,0x%X\n", cheat.xl[0], cheat.xl[1]);
160: }
161: #endif
162:
163:
164:
165: praddr(fp, stg, varno, offset)
166: FILE *fp;
167: int stg, varno;
168: ftnint offset;
169: {
170: char *memname();
171:
172: if(stg == STGNULL)
173: fprintf(fp, "\t.long\t0\n");
174: else
175: {
176: fprintf(fp, "\t.long\t%s", memname(stg,varno));
177: if(offset)
178: fprintf(fp, "+%ld", offset);
179: fprintf(fp, "\n");
180: }
181: }
182:
183:
184:
185:
186: preven(k)
187: int k;
188: {
189: register int lg;
190:
191: if(k > 4)
192: lg = 3;
193: else if(k > 2)
194: lg = 2;
195: else if(k > 1)
196: lg = 1;
197: else
198: return;
199: fprintf(asmfile, "\t.align\t%d\n", lg);
200: }
201:
202:
203:
204: vaxgoto(index, nlab, labs)
205: expptr index;
206: register int nlab;
207: struct Labelblock *labs[];
208: {
209: register int i;
210: register int arrlab;
211:
212: putforce(TYINT, index);
213: p2pi("\tcasel\tr0,$1,$%d", nlab-1);
214: p2pi("L%d:", arrlab = newlabel() );
215: for(i = 0; i< nlab ; ++i)
216: if( labs[i] )
217: p2pij("\t.word\tL%d-L%d", labs[i]->labelno, arrlab);
218: }
219:
220:
221: prarif(p, neg, zer, pos)
222: expptr p;
223: int neg, zer, pos;
224: {
225: int vtype = p->headblock.vtype; /* putforce() will free p */
226: putforce(p->headblock.vtype, p);
227: if( ISINT(vtype) )
228: p2pass("\ttstl\tr0");
229: else
230: p2pass("\ttstd\tr0");
231: p2pi("\tjlss\tL%d", neg);
232: p2pi("\tjeql\tL%d", zer);
233: p2pi("\tjbr\tL%d", pos);
234: }
235:
236:
237:
238:
239: char *memname(stg, mem)
240: int stg, mem;
241: {
242: static char s[20];
243:
244: switch(stg)
245: {
246: case STGCOMMON:
247: case STGEXT:
248: sprintf(s, "_%s", varstr(XL, extsymtab[mem].extname) );
249: break;
250:
251: case STGBSS:
252: case STGINIT:
253: sprintf(s, "v.%d", mem);
254: break;
255:
256: case STGCONST:
257: sprintf(s, "L%d", mem);
258: break;
259:
260: case STGEQUIV:
261: sprintf(s, "q.%d", mem+eqvstart);
262: break;
263:
264: default:
265: badstg("memname", stg);
266: }
267: return(s);
268: }
269:
270: /*
271: * this shouldn't be here (or memname shouldn't)
272: * but i'm too lazy to fix it
273: */
274:
275: char *
276: ftnname(stg, name)
277: char *name;
278: {
279: static char s[40];
280:
281: switch (stg) {
282: case STGCOMMON:
283: case STGEXT:
284: sprintf(s, "_%s", varstr(XL, name) );
285: break;
286: default:
287: badstg("ftnname", stg);
288: }
289: return (s);
290: }
291:
292:
293:
294:
295: prlocvar(s, len)
296: char *s;
297: ftnint len;
298: {
299: fprintf(asmfile, "\t.lcomm\t%s,%ld\n", s, len);
300: }
301:
302:
303:
304: prext(name, leng, init)
305: char *name;
306: ftnint leng;
307: int init;
308: {
309: if(leng == 0)
310: fprintf(asmfile, "\t.globl\t_%s\n", name);
311: else
312: fprintf(asmfile, "\t.comm\t_%s,%ld\n", name, leng);
313: }
314:
315:
316:
317:
318:
319: prendproc()
320: {
321: }
322:
323:
324:
325:
326: prtail()
327: {
328: }
329:
330:
331:
332:
333:
334: prolog(ep, argvec)
335: struct Entrypoint *ep;
336: Addrp argvec;
337: {
338: int i, argslot;
339: int size;
340: register chainp p;
341: register Namep q;
342: register struct Dimblock *dp;
343: expptr tp;
344:
345: p2pass("\t.align\t1");
346:
347:
348: if(procclass == CLMAIN) {
349: if(fudgelabel)
350: {
351: if(ep->entryname) {
352: p2ps("_%s:", varstr(XL, ep->entryname->extname));
353: p2pi("\t.word\tLWM%d", procno);
354: }
355: putlabel(fudgelabel);
356: fudgelabel = 0;
357: fixlwm();
358: }
359: else
360: {
361: p2pass( "_MAIN__:" );
362: if(ep->entryname == NULL)
363: p2pi("\t.word\tLWM%d", procno);
364: }
365:
366: } else if(ep->entryname)
367: if(fudgelabel)
368: {
369: putlabel(fudgelabel);
370: fudgelabel = 0;
371: fixlwm();
372: }
373: else
374: {
375: p2ps("_%s:", varstr(XL, ep->entryname->extname));
376: p2pi("\t.word\tLWM%d", procno);
377: prsave(newlabel());
378: }
379:
380: if(procclass == CLBLOCK)
381: return;
382: if(argvec)
383: {
384: argloc = argvec->memoffset->constblock.Const.ci + SZINT;
385: /* first slot holds count */
386: if(proctype == TYCHAR)
387: {
388: mvarg(TYADDR, 0, chslot);
389: mvarg(TYLENG, SZADDR, chlgslot);
390: argslot = SZADDR + SZLENG;
391: }
392: else if( ISCOMPLEX(proctype) )
393: {
394: mvarg(TYADDR, 0, cxslot);
395: argslot = SZADDR;
396: }
397: else
398: argslot = 0;
399:
400: for(p = ep->arglist ; p ; p =p->nextp)
401: {
402: q = (Namep) (p->datap);
403: mvarg(TYADDR, argslot, q->vardesc.varno);
404: argslot += SZADDR;
405: }
406: for(p = ep->arglist ; p ; p = p->nextp)
407: {
408: q = (Namep) (p->datap);
409: if(q->vtype==TYCHAR && q->vclass!=CLPROC)
410: {
411: if(q->vleng && ! ISCONST(q->vleng) )
412: mvarg(TYLENG, argslot,
413: q->vleng->addrblock.memno);
414: argslot += SZLENG;
415: }
416: }
417: p2pi("\taddl3\t$%d,fp,ap", argloc-ARGOFFSET);
418: p2pi("\tmovl\t$%d,(ap)\n", lastargslot/SZADDR);
419: }
420:
421: for(p = ep->arglist ; p ; p = p->nextp)
422: {
423: q = (Namep) (p->datap);
424: if(dp = q->vdim)
425: {
426: for(i = 0 ; i < dp->ndim ; ++i)
427: if(dp->dims[i].dimexpr)
428: puteq( fixtype(cpexpr(dp->dims[i].dimsize)),
429: fixtype(cpexpr(dp->dims[i].dimexpr)));
430: size = typesize[ q->vtype ];
431: if(q->vtype == TYCHAR)
432: if( ISICON(q->vleng) )
433: size *= q->vleng->constblock.Const.ci;
434: else
435: size = -1;
436:
437: /* on VAX, get more efficient subscripting if subscripts
438: have zero-base, so fudge the argument pointers for arrays.
439: Not done if array bounds are being checked.
440: */
441: if(dp->basexpr)
442: puteq( cpexpr(fixtype(dp->baseoffset)),
443: cpexpr(dp->basexpr = fixtype(dp->basexpr)));
444:
445: if(! checksubs)
446: {
447: if(dp->basexpr)
448: {
449: if(size > 0)
450: tp = (expptr) ICON(size);
451: else
452: tp = (expptr) cpexpr(q->vleng);
453: putforce(TYINT,
454: fixtype( mkexpr(OPSTAR, tp,
455: cpexpr(dp->baseoffset)) ));
456: p2pi("\tsubl2\tr0,%d(ap)",
457: p->datap->nameblock.vardesc.varno +
458: ARGOFFSET);
459: }
460: else if(dp->baseoffset->constblock.Const.ci != 0)
461: {
462: char buff[25];
463: if(size > 0)
464: {
465: sprintf(buff, "\tsubl2\t$%ld,%d(ap)",
466: dp->baseoffset->constblock.Const.ci * size,
467: p->datap->nameblock.vardesc.varno +
468: ARGOFFSET);
469: }
470: else {
471: putforce(TYINT, mkexpr(OPSTAR, cpexpr(dp->baseoffset),
472: cpexpr(q->vleng) ));
473: sprintf(buff, "\tsubl2\tr0,%d(ap)",
474: p->datap->nameblock.vardesc.varno +
475: ARGOFFSET);
476: }
477: p2pass(buff);
478: }
479: }
480: }
481: }
482:
483: if(typeaddr)
484: puteq( cpexpr(typeaddr), mkaddcon(ep->typelabel) );
485: /* replace to avoid long jump problem
486: putgoto(ep->entrylabel);
487: */
488: p2pi("\tjmp\tL%d", ep->entrylabel);
489: }
490:
491: fixlwm()
492: {
493: extern lwmno;
494: if (lwmno == procno)
495: return;
496: fprintf(asmfile, "\t.set\tLWM%d,0x%x\n",
497: procno, regmask[highregvar]);
498: lwmno = procno;
499: }
500:
501:
502: prhead(fp)
503: FILEP fp;
504: {
505: #if FAMILY==PCC
506: p2triple(P2LBRACKET, ARGREG-highregvar, procno);
507: p2word( (long) (BITSPERCHAR*autoleng) );
508: p2flush();
509: #endif
510: }
511:
512:
513:
514: prdbginfo()
515: {
516: }
517:
518: #ifdef SDB
519:
520:
521: # ifdef UCBVAXASM
522: char *stabdline(code, type)
523: int code;
524: int type;
525: {
526: static char buff[30];
527:
528: sprintf(buff, "\t.stabd\t0x%x,0,%d", code, type);
529: return(buff);
530: }
531: # endif
532:
533:
534: prstab(s, code, type, loc)
535: char *s, *loc;
536: int code, type;
537: {
538: char * stabline();
539:
540: if(sdbflag)
541: p2pass( stabline(s,code,type,loc) );
542: }
543:
544:
545:
546: char *stabline(s, code, type, loc)
547: register char *s;
548: int code;
549: int type;
550: char *loc;
551: {
552: static char buff[512] = "\t.stab\t\t";
553: register char *t;
554: register int i = 0;
555:
556: #ifdef UCBVAXASM
557: t = buff + 8;
558: if(s == NULL)
559: buff[6] = 'n'; /* .stabn line */
560: else
561: {
562: buff[6] = 's'; /* .stabs line */
563: *t++ = '"';
564: while(*s!='\0' && *s!=' ')
565: {
566: #ifndef UCBPASS2
567: if (i == 8)
568: break;
569: #endif
570: *t++ = *s++;
571: ++i;
572: }
573: *t++ = '"';
574: *t++ = ',';
575: }
576:
577: #else
578: t = buff + 7;
579: if(s)
580: while( *s!='\0' && *s!=' ' && i<8 )
581: {
582: *t++ = '\'';
583: *t++ = *s++;
584: *t++ = ',';
585: ++i;
586: }
587: for( ; i<8 ; ++i)
588: {
589: *t++ = '0';
590: *t++ = ',';
591: }
592: #endif
593:
594:
595: sprintf(t, "0x%x,0,%d,%s", code, type, (loc? loc : "0") );
596: return(buff);
597: }
598:
599:
600: /* type cookies for pi */
601:
602: #define BASIC 5 /* width of basic type */
603: #define PTR 01 /* pointer */
604: #define FTN 02 /* function */
605: #define ARY 03 /* array */
606: #define OF 2 /* shift for `ftn ary ptr of' */
607:
608: /*
609: * extra table of our types to sdb's types
610: * our code generator is still pcc1, but sdb expects pcc2
611: * to be safe, say exactly what we mean here
612: */
613:
614: int sdbtypes[] = {
615: 0, /* TYUNKNOWN 0 */
616: PTR|4, /* TYADDR 1 == ptr to int. eh? */
617: 3, /* TYSHORT 2 */
618: 5, /* TYLONG 3 */
619: 6, /* TYREAL 4 */
620: 7, /* TYDREAL 5 */
621: 6, /* TYCOMPLEX 6 == float */
622: 7, /* TYDCOMPLEX 7 == double */
623: 5, /* TYLOGICAL 8 == long? */
624: 2, /* TYCHAR 9 */
625: 4, /* TYSUBR 10 == int */
626: 0, /* TYERROR 11 */
627: };
628:
629: #define STRTY 8
630: #define VOID 16
631:
632: stabtype(p)
633: register Namep p;
634: {
635: register int func = 0, type = 0, vt = p->vtype;
636: if(p->vstg == STGARG) {
637: type = PTR;
638: if(p->vclass == CLPROC) {
639: type = (FTN << OF) | PTR;
640: func = 1;
641: }
642: }
643: else if(p->vdim)
644: type = ARY;
645: else if(p->vclass == CLPROC) {
646: type = FTN;
647: func = 1;
648: }
649: type <<= BASIC;
650: if (func && (ISCOMPLEX(vt) || vt == TYCHAR))
651: type |= VOID;
652: else
653: type |= ISCOMPLEX(vt) ? STRTY : types2[vt];
654: if (type == 2) type |= (ARY << BASIC);
655: return type;
656: }
657:
658: prstabtype(xp, q, stype, loc)
659: struct Extsym *xp;
660: register Namep q;
661: char *loc;
662: {
663: int i;
664: char *name, *tyid = 0;
665: ftnint nelt = 0;
666: static char *dc[2] = {
667: "complex", "dcomplex" };
668:
669: prstab(name = varstr(VL,q->varname), stype, i = stabtype(q), loc);
670: if (ISCOMPLEX(q->vtype))
671: prstab(tyid = dc[q->vtype - TYCOMPLEX], N_TYID, 0, CNULL);
672: if (ISARRAY(i))
673: p2pass(stabdline(N_DIM, (int)(nelt = i1arrlen(q))));
674: if (xp)
675: commvar(name, nelt, q, tyid, i, xp);
676: }
677:
678:
679:
680: prcomssym(np, xp)
681: register Namep np;
682: register struct Extsym *xp;
683: {
684: char nbuf[40];
685:
686: sprintf(nbuf, "%d", np->voffset);
687: prstabtype(xp, np, N_SSYM, nbuf);
688: }
689:
690: #define Sgulp 2040
691: #define CVgulp 120
692:
693: /* For each common block, save the first appearance of each */
694: /* variable, along with its offset and type, for adding common */
695: /* block structures to pi's global menu */
696: commvar(name, nelt, p, tyid, type, v)
697: register char *name;
698: ftnint nelt;
699: Namep p;
700: char *tyid;
701: register struct Extsym *v;
702: {
703: static char *slast, *snext;
704: static struct Comvar *cvlast, *cvnext;
705: char *malloc(), *strcpy();
706: char *s;
707: struct Comvar *cv, *cv0, *ncv;
708: int k;
709:
710: for (cv = cv0 = v->cv; cv; cv0 = cv, cv = cv->next)
711: if (!strcmp(name, cv->name))
712: return;
713: k = strlen(name) + 1;
714: s = snext;
715: snext += k;
716: if (snext > slast) {
717: if (!(s = malloc(Sgulp)))
718: mfailure:
719: fatal("Out of memory in commvar");
720: snext = s + k;
721: slast = s + Sgulp;
722: }
723: if (cvnext >= cvlast) {
724: cvnext = (struct Comvar *)
725: malloc(CVgulp*sizeof(struct Comvar));
726: if (!cvnext)
727: goto mfailure;
728: cvlast = cvnext + CVgulp;
729: }
730: ncv = cvnext++;
731: if (cv0) cv0->next = ncv;
732: else v->cv = ncv;
733: ncv->next = 0;
734: ncv->name = strcpy(s,name);
735: ncv->type = type;
736: ncv->tyid = tyid;
737: ncv->offset = p->voffset;
738: ncv->nelt = nelt;
739: }
740: #endif
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.