1: #include "defs" 2: 3: struct varblock *subscript(v,s) 4: register ptr v,s; 5: { 6: ptr p; 7: register ptr q; 8: ptr bounds, subs; 9: int size, align, mask; 10: 11: if(v->tag == TERROR) 12: goto ret; 13: if(v->tag!=TNAME && v->tag!=TTEMP) 14: badtag("subscript", v->tag); 15: if(s->tag == TERROR) 16: { 17: v->vsubs = 0; 18: goto ret; 19: } 20: 21: if(s->tag != TLIST) 22: badtag("subscript", s->tag); 23: sizalign(v, &size, &align, &mask); 24: if(bounds = v->vdim) 25: bounds = bounds->datap; 26: subs = s->leftp; 27: 28: while ( bounds && subs) 29: { 30: if(bounds->lowerb) 31: { 32: p = mknode(TAROP,OPMINUS,mkint(1),cpexpr(bounds->lowerb)); 33: subs->datap = mknode(TAROP,OPPLUS, subs->datap, p); 34: } 35: bounds = bounds->nextp; 36: subs = subs->nextp; 37: } 38: v->vdim = 0; 39: if(bounds || subs) 40: { 41: exprerr("subscript and bounds of different length", CNULL); 42: v->vsubs = 0; 43: goto ret; 44: } 45: 46: if(v->vsubs) 47: { /* special case of subscripted type element */ 48: if(s->leftp==0 || s->leftp->nextp!=0) 49: { 50: exprerr("not exactly one subscript on type member", CNULL); 51: v->vsubs = 0; 52: goto ret; 53: } 54: q = mknode(TAROP,OPMINUS,s->leftp->datap, mkint(1) ); 55: q = mknode(TAROP,OPSTAR, mkint(size), q); 56: if(v->voffset) 57: v->voffset = mknode(TAROP,OPPLUS,v->voffset, q); 58: else v->voffset = q; 59: goto ret; 60: } 61: 62: v->vsubs = s; 63: 64: if(v->vtype==TYCHAR || v->vtype==TYSTRUCT || 65: (v->vtype==TYLCOMPLEX && tailor.lngcxtype==NULL) ) 66: { /* add an initial unit subscript */ 67: s->leftp = mkchain(mkint(1), s->leftp); 68: } 69: 70: else { /* add to offset, set first subscript to 1 */ 71: q = mknode(TAROP,OPMINUS,s->leftp->datap, mkint(1) ); 72: q = mknode(TAROP,OPSTAR, mkint(size), q); 73: if(v->voffset) 74: v->voffset = mknode(TAROP,OPPLUS,v->voffset, q); 75: else v->voffset = q; 76: 77: s->leftp->datap = mkint(1); 78: } 79: ret: 80: return(v); 81: } 82: 83: 84: 85: 86: 87: ptr strucelt(var, subelt) 88: register ptr var; 89: ptr subelt; 90: { 91: register ptr p, q; 92: 93: if(var->tag == TERROR) 94: return(var); 95: if(var->vtype!=TYSTRUCT || var->vtypep==0 || var->vdim!=0) 96: { 97: exprerr("attempt to find a member in an array or non-structure", CNULL); 98: return(errnode()); 99: } 100: for(p = var->vtypep->strdesc ; p ; p = p->nextp) 101: if(subelt == p->datap->sthead) break; 102: if(p == 0) 103: { 104: exprerr("%s is not in structure\n", subelt->namep); 105: return(errnode()); 106: } 107: q = p->datap; 108: var->vdim = q->vdim; 109: var->vtypep = q->vtypep; 110: if(q->voffset) 111: if(var->voffset) 112: var->voffset = mknode(TAROP,OPPLUS,var->voffset,cpexpr(q->voffset)); 113: else { 114: var->voffset = cpexpr(q->voffset); 115: } 116: if( (var->vtype = q->vtype) != TYSTRUCT) 117: convtype(var); 118: return(var); 119: } 120: 121: 122: 123: convtype(p) 124: register ptr p; 125: { 126: register int i, k; 127: ptr mksub1(); 128: 129: switch(p->vtype) 130: { 131: case TYFIELD: 132: case TYINT: 133: case TYCHAR: 134: case TYREAL: 135: case TYLREAL: 136: case TYCOMPLEX: 137: case TYLOG: 138: k = eflftn[p->vtype]; 139: break; 140: 141: default: 142: fatal("convtype: impossible type"); 143: } 144: 145: for(i=0; i<NFTNTYPES; ++i) 146: if(i != k) p->vbase[i] = 0; 147: else if(p->vbase[i]==0) 148: { 149: exprerr("illegal combination of array and dot",CNULL); 150: mvexpr(errnode(), p); 151: return; 152: } 153: 154: if(p->vsubs == 0) 155: p->vsubs = mksub1(); 156: 157: } 158: 159: 160: 161: fixsubs(p) 162: register ptr p; 163: { 164: ptr q, *firstsub; 165: int size,align,mask; 166: 167: if(p->voffset) 168: { 169: firstsub = &(p->vsubs->leftp->datap); 170: sizalign(p, &size,&align,&mask); 171: if(p->vtype == TYCHAR) 172: size = tailor.ftnsize[FTNINT]; 173: 174: q = mknode(TAROP,OPSLASH,p->voffset,mkint(size)); 175: *firstsub = mknode(TAROP,OPPLUS, q, *firstsub); 176: p->voffset = 0; 177: } 178: }