2.11BSD#431 - /usr/src/ucb/PORT/pascal/src/clas.c

   1: /*
   2:  * Copyright (c) 1980 Regents of the University of California.
   3:  * All rights reserved.  The Berkeley software License Agreement
   4:  * specifies the terms and conditions for redistribution.
   5:  */
   6: 
   7: #ifndef lint
   8: static char sccsid[] = "@(#)clas.c	5.2 (Berkeley) 6/5/85";
   9: #endif not lint
  10: #include "whoami.h"
  11: #include "0.h"
  12: #include "tree.h"
  13: #include "tree_ty.h"
  14: 
  15: /*
  16:  * This is the array of class
  17:  * names for the classes returned
  18:  * by classify.  The order of the
  19:  * classes is the same as the base
  20:  * of the namelist, with special
  21:  * negative index entries for structures,
  22:  * scalars, pointers, sets and strings
  23:  * to be collapsed into.
  24:  */
  25: char    *clnxxxx[] =
  26: {
  27:     "file",         /* -7	TFILE */
  28:     "record",       /* -6	TREC */
  29:     "array",        /* -5	TARY */
  30:     "scalar",       /* -4	TSCAL */
  31:     "pointer",      /* -3	TPTR */
  32:     "set",          /* -2	TSET */
  33:     "string",       /* -1	TSTR */
  34:     "SNARK",        /*  0	NIL */
  35:     "Boolean",      /*  1	TBOOL */
  36:     "char",         /*  2	TCHAR */
  37:     "integer",      /*  3	TINT */
  38:     "real",         /*  4	TREAL */
  39:     "\"nil\"",      /*  5	TNIL */
  40: };
  41: 
  42: char **clnames  = &clnxxxx[-(TFIRST)];
  43: 
  44: /*
  45:  * Classify takes a pointer
  46:  * to a type and returns one
  47:  * of several interesting group
  48:  * classifications for easy use.
  49:  */
  50: classify(p1)
  51:     struct nl *p1;
  52: {
  53:     register struct nl *p;
  54: 
  55:     p = p1;
  56: swit:
  57:     if (p == NLNIL) {
  58:         nocascade();
  59:         return (NIL);
  60:     }
  61:     if (p == &nl[TSTR])
  62:         return (TSTR);
  63:     if ( p == &nl[ TSET ] ) {
  64:         return TSET;
  65:     }
  66:     switch (p->class) {
  67:         case PTR:
  68:             return (TPTR);
  69:         case ARRAY:
  70:             if (p->type == nl+T1CHAR)
  71:                 return (TSTR);
  72:             return (TARY);
  73:         case STR:
  74:             return (TSTR);
  75:         case SET:
  76:             return (TSET);
  77:         case CRANGE:
  78:         case RANGE:
  79:             p = p->type;
  80:             goto swit;
  81:         case TYPE:
  82:             if (p <= nl+TLAST)
  83:                 return (p - nl);
  84:             panic("clas2");
  85:         case FILET:
  86:             return (TFILE);
  87:         case RECORD:
  88:             return (TREC);
  89:         case SCAL:
  90:             return (TSCAL);
  91:         default:
  92:             {
  93:                 panic("clas");
  94:                 return(NIL);
  95:             }
  96:     }
  97: }
  98: 
  99: #ifndef PI0
 100: /*
 101:  * Is p a text file?
 102:  */
 103: text(p)
 104:     struct nl *p;
 105: {
 106: 
 107:     return (p != NIL && p->class == FILET && p->type == nl+T1CHAR);
 108: }
 109: #endif
 110: 
 111: /*
 112:  * Scalar returns a pointer to
 113:  * the the base scalar type of
 114:  * its argument if its argument
 115:  * is a SCALar else NIL.
 116:  */
 117: struct nl *
 118: scalar(p1)
 119:     struct nl *p1;
 120: {
 121:     register struct nl *p;
 122: 
 123:     p = p1;
 124:     if (p == NLNIL)
 125:         return (NLNIL);
 126:     if (p->class == RANGE || p->class == CRANGE)
 127:         p = p->type;
 128:     if (p == NLNIL)
 129:         return (NLNIL);
 130:     return (p->class == SCAL ? p : NLNIL);
 131: }
 132: 
 133: /*
 134:  * Isa tells whether p
 135:  * is one of a group of
 136:  * namelist classes.  The
 137:  * classes wanted are specified
 138:  * by the characters in s.
 139:  * (Note that s would more efficiently,
 140:  * if less clearly, be given by a mask.)
 141:  */
 142: isa(p, s)
 143:     register struct nl *p;
 144:     char *s;
 145: {
 146:     register i;
 147:     register char *cp;
 148: 
 149:     if (p == NIL)
 150:         return (NIL);
 151:     /*
 152: 	 * map ranges down to
 153: 	 * the base type
 154: 	 */
 155:     if (p->class == RANGE) {
 156:         p = p->type;
 157:     }
 158:     /*
 159: 	 * the following character/class
 160: 	 * associations are made:
 161: 	 *
 162: 	 *	s	scalar
 163: 	 *	b	Boolean
 164: 	 *	c	character
 165: 	 *	i	integer
 166: 	 *	d	double (real)
 167: 	 *	t	set
 168: 	 */
 169:     switch (p->class) {
 170:         case SET:
 171:             i = TDOUBLE+1;
 172:             break;
 173:         case SCAL:
 174:             i = 0;
 175:             break;
 176:         case CRANGE:
 177:             /*
 178: 			 * find the base type of a conformant array range
 179: 			 */
 180:             switch (classify(p->type)) {
 181:                 case TBOOL: i = 1; break;
 182:                 case TCHAR: i = 2; break;
 183:                 case TINT: i = 3; break;
 184:                 case TSCAL: i = 0; break;
 185:                 default:
 186:                     panic( "isa" );
 187:             }
 188:             break;
 189:         default:
 190:             i = p - nl;
 191:     }
 192:     if (i >= 0 && i <= TDOUBLE+1) {
 193:         i = "sbcidt"[i];
 194:         cp = s;
 195:         while (*cp)
 196:             if (*cp++ == i)
 197:                 return (1);
 198:     }
 199:     return (NIL);
 200: }
 201: 
 202: /*
 203:  * Isnta is !isa
 204:  */
 205: isnta(p, s)
 206:     struct nl *p;
 207:     char *s;
 208: {
 209: 
 210:     return (!isa(p, s));
 211: }
 212: 
 213: /*
 214:  * "shorthand"
 215:  */
 216: char *
 217: nameof(p)
 218: struct nl *p;
 219: {
 220: 
 221:     return (clnames[classify(p)]);
 222: }
 223: 
 224: #ifndef PI0
 225: /* find out for sure what kind of node this is being passed
 226:    possibly several different kinds of node are passed to it */
 227: int nowexp(r)
 228:     struct tnode *r;
 229: {
 230:     if (r->tag == T_WEXP) {
 231:         if (r->var_node.cptr == NIL)
 232:             error("Oct/hex allowed only on writeln/write calls");
 233:         else
 234:             error("Width expressions allowed only in writeln/write calls");
 235:         return (1);
 236:     }
 237:     return (NIL);
 238: }
 239: #endif
 240: 
 241:     /*
 242:      *	is a variable a local, a formal parameter, or a global?
 243:      *	all this from just the offset:
 244:      *	    globals are at levels 0 or 1
 245:      *	    positives are parameters
 246:      *	    negative evens are locals
 247:      */
 248: /*ARGSUSED*/
 249: whereis( offset , other_flags )
 250:     int     offset;
 251:     char    other_flags;
 252: {
 253: 
 254: #   ifdef OBJ
 255:     return ( offset >= 0 ? PARAMVAR : LOCALVAR );
 256: #   endif OBJ
 257: #   ifdef PC
 258:     switch ( other_flags & ( NGLOBAL | NPARAM | NLOCAL | NNLOCAL) ) {
 259:         default:
 260:         panic( "whereis" );
 261:         case NGLOBAL:
 262:         return GLOBALVAR;
 263:         case NPARAM:
 264:         return PARAMVAR;
 265:         case NNLOCAL:
 266:         return NAMEDLOCALVAR;
 267:         case NLOCAL:
 268:         return LOCALVAR;
 269:     }
 270: #   endif PC
 271: }

Defined functions

Defined variables