| 1 | /* Copyright (c) 1979 Regents of the University of California */ |
| 2 | # |
| 3 | /* |
| 4 | * pi - Pascal interpreter code translator |
| 5 | * |
| 6 | * Charles Haley, Bill Joy UCB |
| 7 | * Version 1.1 February 1978 |
| 8 | * |
| 9 | * |
| 10 | * pxp - Pascal execution profiler |
| 11 | * |
| 12 | * Bill Joy UCB |
| 13 | * Version 1.1 February 1978 |
| 14 | */ |
| 15 | |
| 16 | #include "whoami" |
| 17 | #include "0.h" |
| 18 | #include "yy.h" |
| 19 | |
| 20 | #ifdef PI |
| 21 | extern int *yypv; |
| 22 | /* |
| 23 | * Determine whether the identifier whose name |
| 24 | * is "cp" can possibly be a kind, which is a |
| 25 | * namelist class. We look through the symbol |
| 26 | * table for the first instance of cp as a non-field, |
| 27 | * and at all instances of cp as a field. |
| 28 | * If any of these are ok, we return true, else false. |
| 29 | * It would be much better to handle with's correctly, |
| 30 | * even to just know whether we are in a with at all. |
| 31 | * |
| 32 | * Note that we don't disallow constants on the lhs of assignment. |
| 33 | */ |
| 34 | identis(cp, kind) |
| 35 | register char *cp; |
| 36 | int kind; |
| 37 | { |
| 38 | register struct nl *p; |
| 39 | int i; |
| 40 | |
| 41 | /* |
| 42 | * Cp is NIL when error recovery inserts it. |
| 43 | */ |
| 44 | if (cp == NIL) |
| 45 | return (1); |
| 46 | |
| 47 | /* |
| 48 | * Record kind we want for possible later use by yyrecover |
| 49 | */ |
| 50 | yyidwant = kind; |
| 51 | yyidhave = NIL; |
| 52 | i = ( (int) cp ) & 077; |
| 53 | for (p = disptab[i]; p != NIL; p = p->nl_next) |
| 54 | if (p->symbol == cp) { |
| 55 | if (yyidok(p, kind)) |
| 56 | goto gotit; |
| 57 | if (p->class != FIELD && p->class != BADUSE) |
| 58 | break; |
| 59 | } |
| 60 | if (p != NIL) |
| 61 | for (p = p->nl_next; p != NIL; p = p->nl_next) |
| 62 | if (p->symbol == cp && p->class == FIELD && yyidok(p, kind)) |
| 63 | goto gotit; |
| 64 | return (0); |
| 65 | gotit: |
| 66 | if (p->class == BADUSE && !Recovery) { |
| 67 | yybadref(p, OY.Yyeline); |
| 68 | yypv[0] = NIL; |
| 69 | } |
| 70 | return (1); |
| 71 | } |
| 72 | \f |
| 73 | /* |
| 74 | * A bad reference to the identifier cp on line |
| 75 | * line and use implying the addition of kindmask |
| 76 | * to the mask of kind information. |
| 77 | */ |
| 78 | yybaduse(cp, line, kindmask) |
| 79 | register char *cp; |
| 80 | int line, kindmask; |
| 81 | { |
| 82 | register struct nl *p, *oldp; |
| 83 | int i; |
| 84 | |
| 85 | i = ( (int) cp ) & 077; |
| 86 | for (p = disptab[i]; p != NIL; p = p->nl_next) |
| 87 | if (p->symbol == cp) |
| 88 | break; |
| 89 | oldp = p; |
| 90 | if (p == NIL || p->class != BADUSE) |
| 91 | p = enter(defnl(cp, BADUSE, 0, 0)); |
| 92 | p->value[NL_KINDS] =| kindmask; |
| 93 | yybadref(p, line); |
| 94 | return (oldp); |
| 95 | } |
| 96 | |
| 97 | /* |
| 98 | * ud is initialized so that esavestr will allocate |
| 99 | * sizeof ( struct udinfo ) bytes for the 'real' struct udinfo |
| 100 | */ |
| 101 | struct udinfo ud = { ~0 , ~0 , 0}; |
| 102 | /* |
| 103 | * Record a reference to an undefined identifier, |
| 104 | * or one which is improperly used. |
| 105 | */ |
| 106 | yybadref(p, line) |
| 107 | register struct nl *p; |
| 108 | int line; |
| 109 | { |
| 110 | register struct udinfo *udp; |
| 111 | |
| 112 | if (p->chain != NIL && p->chain->ud_line == line) |
| 113 | return; |
| 114 | udp = esavestr(&ud); |
| 115 | udp->ud_line = line; |
| 116 | udp->ud_next = p->chain; |
| 117 | p->chain = udp; |
| 118 | } |
| 119 | |
| 120 | #define varkinds ((1<<CONST)|(1<<VAR)|(1<<REF)|(1<<ARRAY)|(1<<PTR)|(1<<RECORD)|(1<<FIELD)|(1<<FUNC)|(1<<FVAR)) |
| 121 | /* |
| 122 | * Is the symbol in the p entry of the namelist |
| 123 | * even possibly a kind kind? If not, update |
| 124 | * what we have based on this encounter. |
| 125 | */ |
| 126 | yyidok(p, kind) |
| 127 | register struct nl *p; |
| 128 | int kind; |
| 129 | { |
| 130 | |
| 131 | if (p->class == BADUSE) { |
| 132 | if (kind == VAR) |
| 133 | return (p->value[0] & varkinds); |
| 134 | return (p->value[0] & (1 << kind)); |
| 135 | } |
| 136 | if (yyidok1(p, kind)) |
| 137 | return (1); |
| 138 | if (yyidhave != NIL) |
| 139 | yyidhave = IMPROPER; |
| 140 | else |
| 141 | yyidhave = p->class; |
| 142 | return (0); |
| 143 | } |
| 144 | |
| 145 | yyidok1(p, kind) |
| 146 | register struct nl *p; |
| 147 | int kind; |
| 148 | { |
| 149 | int i; |
| 150 | |
| 151 | switch (kind) { |
| 152 | case FUNC: |
| 153 | if (p->class == FVAR) |
| 154 | return(1); |
| 155 | case CONST: |
| 156 | case TYPE: |
| 157 | case PROC: |
| 158 | case FIELD: |
| 159 | return (p->class == kind); |
| 160 | case VAR: |
| 161 | return (p->class == CONST || yyisvar(p, NIL)); |
| 162 | case ARRAY: |
| 163 | case RECORD: |
| 164 | return (yyisvar(p, kind)); |
| 165 | case PTRFILE: |
| 166 | return (yyisvar(p, PTR) || yyisvar(p, FILET)); |
| 167 | } |
| 168 | } |
| 169 | |
| 170 | yyisvar(p, class) |
| 171 | register struct nl *p; |
| 172 | int class; |
| 173 | { |
| 174 | |
| 175 | switch (p->class) { |
| 176 | case FIELD: |
| 177 | case VAR: |
| 178 | case REF: |
| 179 | case FVAR: |
| 180 | /* |
| 181 | * We would prefer to return |
| 182 | * parameterless functions only. |
| 183 | */ |
| 184 | case FUNC: |
| 185 | return (class == NIL || (p->type != NIL && p->type->class == class)); |
| 186 | } |
| 187 | return (0); |
| 188 | } |
| 189 | #endif |
| 190 | #ifdef PXP |
| 191 | #ifndef DEBUG |
| 192 | identis() |
| 193 | { |
| 194 | |
| 195 | return (1); |
| 196 | } |
| 197 | #endif |
| 198 | #ifdef DEBUG |
| 199 | extern char *classes[]; |
| 200 | |
| 201 | char kindchars[] "UCTVAQRDPF"; |
| 202 | /* |
| 203 | * Fake routine "identis" for pxp when testing error recovery. |
| 204 | * Looks at letters in variable names to answer questions |
| 205 | * about attributes. Mapping is |
| 206 | * C const_id |
| 207 | * T type_id |
| 208 | * V var_id also if any of AQRDF |
| 209 | * A array_id |
| 210 | * Q ptr_id |
| 211 | * R record_id |
| 212 | * D field_id D for "dot" |
| 213 | * P proc_id |
| 214 | * F func_id |
| 215 | */ |
| 216 | identis(cp, kind) |
| 217 | register char *cp; |
| 218 | int kind; |
| 219 | { |
| 220 | register char *dp; |
| 221 | char kindch; |
| 222 | |
| 223 | /* |
| 224 | * Don't do anything unless -T |
| 225 | */ |
| 226 | if (!typetest) |
| 227 | return (1); |
| 228 | |
| 229 | /* |
| 230 | * Inserted symbols are always correct |
| 231 | */ |
| 232 | if (cp == NIL) |
| 233 | return (1); |
| 234 | /* |
| 235 | * Set up the names for error messages |
| 236 | */ |
| 237 | yyidwant = classes[kind]; |
| 238 | for (dp = kindchars; *dp; dp++) |
| 239 | if (any(cp, *dp)) { |
| 240 | yyidhave = classes[dp - kindchars]; |
| 241 | break; |
| 242 | } |
| 243 | |
| 244 | /* |
| 245 | * U in the name means undefined |
| 246 | */ |
| 247 | if (any(cp, 'U')) |
| 248 | return (0); |
| 249 | |
| 250 | kindch = kindchars[kind]; |
| 251 | if (kindch == 'V') |
| 252 | for (dp = "AQRDF"; *dp; dp++) |
| 253 | if (any(cp, *dp)) |
| 254 | return (1); |
| 255 | return (any(cp, kindch)); |
| 256 | } |
| 257 | #endif |
| 258 | #endif |