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

   1: /*	@(#)clas.c	2.2	SCCS id keyword	*/
   2: /* Copyright (c) 1979 Regents of the University of California */
   3: #
   4: /*
   5:  * pi - Pascal interpreter code translator
   6:  *
   7:  * Charles Haley, Bill Joy UCB
   8:  * Version 1.2 November 1978
   9:  */
  10: 
  11: #include "whoami"
  12: #include "0.h"
  13: #include "tree.h"
  14: #include "opcode.h"
  15: 
  16: /*
  17:  * This is the array of class
  18:  * names for the classes returned
  19:  * by classify.  The order of the
  20:  * classes is the same as the base
  21:  * of the namelist, with special
  22:  * negative index entries for structures,
  23:  * scalars, pointers, sets and strings
  24:  * to be collapsed into.
  25:  */
  26: char    *clnxxxx[] =
  27: {
  28:     "file",         /* -7	TFILE */
  29:     "record",       /* -6	TREC */
  30:     "array",        /* -5	TARY */
  31:     "scalar",       /* -4	TSCAL */
  32:     "pointer",      /* -3	TPTR */
  33:     "set",          /* -2	TSET */
  34:     "string",       /* -1	TSTR */
  35:     "SNARK",        /*  0	NIL */
  36:     "Boolean",      /*  1	TBOOL */
  37:     "char",         /*  2	TCHAR */
  38:     "integer",      /*  3	TINT */
  39:     "real",         /*  4	TREAL */
  40:     "\"nil\"",      /*  5	TNIL */
  41: };
  42: 
  43: char **clnames  = &clnxxxx[-(TFIRST)];
  44: 
  45: /*
  46:  * Classify takes a pointer
  47:  * to a type and returns one
  48:  * of several interesting group
  49:  * classifications for easy use.
  50:  */
  51: classify(p1)
  52:     struct nl *p1;
  53: {
  54:     register struct nl *p;
  55: 
  56:     p = p1;
  57: swit:
  58:     if (p == NIL) {
  59:         nocascade();
  60:         return (NIL);
  61:     }
  62:     if (p == &nl[TSTR])
  63:         return (TSTR);
  64:     switch (p->class) {
  65:         case PTR:
  66:             return (TPTR);
  67:         case ARRAY:
  68:             if (p->type == nl+T1CHAR)
  69:                 return (TSTR);
  70:             return (TARY);
  71:         case STR:
  72:             return (TSTR);
  73:         case SET:
  74:             return (TSET);
  75:         case RANGE:
  76:             p = p->type;
  77:             goto swit;
  78:         case TYPE:
  79:             if (p <= nl+TLAST)
  80:                 return (p - nl);
  81:             panic("clas2");
  82:         case FILET:
  83:             return (TFILE);
  84:         case RECORD:
  85:             return (TREC);
  86:         case SCAL:
  87:             return (TSCAL);
  88:         default:
  89:             panic("clas");
  90:     }
  91: }
  92: 
  93: #ifndef PI0
  94: /*
  95:  * Is p a text file?
  96:  */
  97: text(p)
  98:     struct nl *p;
  99: {
 100: 
 101:     return (p != NIL && p->class == FILET && p->type == nl+T1CHAR);
 102: }
 103: #endif
 104: 
 105: /*
 106:  * Scalar returns a pointer to
 107:  * the the base scalar type of
 108:  * its argument if its argument
 109:  * is a SCALar else NIL.
 110:  */
 111: scalar(p1)
 112:     struct nl *p1;
 113: {
 114:     register struct nl *p;
 115: 
 116:     p = p1;
 117:     if (p == NIL)
 118:         return (NIL);
 119:     if (p->class == RANGE)
 120:         p = p->type;
 121:     if (p == NIL)
 122:         return (NIL);
 123:     return (p->class == SCAL ? p : NIL);
 124: }
 125: 
 126: /*
 127:  * Isa tells whether p
 128:  * is one of a group of
 129:  * namelist classes.  The
 130:  * classes wanted are specified
 131:  * by the characters in s.
 132:  * (Note that s would more efficiently,
 133:  * if less clearly, be given by a mask.)
 134:  */
 135: isa(p, s)
 136:     register struct nl *p;
 137:     char *s;
 138: {
 139:     register i;
 140:     register char *cp;
 141: 
 142:     if (p == NIL)
 143:         return (NIL);
 144:     /*
 145: 	 * map ranges down to
 146: 	 * the base type
 147: 	 */
 148:     if (p->class == RANGE)
 149:         p = p->type;
 150:     /*
 151: 	 * the following character/class
 152: 	 * associations are made:
 153: 	 *
 154: 	 *	s	scalar
 155: 	 *	b	Boolean
 156: 	 *	c	character
 157: 	 *	i	integer
 158: 	 *	d	double (real)
 159: 	 *	t	set
 160: 	 */
 161:     switch (p->class) {
 162:         case SET:
 163:             i = TDOUBLE+1;
 164:             break;
 165:         case SCAL:
 166:             i = 0;
 167:             break;
 168:         default:
 169:             i = p - nl;
 170:     }
 171:     if (i >= 0 && i <= TDOUBLE+1) {
 172:         i = "sbcidt"[i];
 173:         cp = s;
 174:         while (*cp)
 175:             if (*cp++ == i)
 176:                 return (1);
 177:     }
 178:     return (NIL);
 179: }
 180: 
 181: /*
 182:  * Isnta is !isa
 183:  */
 184: isnta(p, s)
 185: {
 186: 
 187:     return (!isa(p, s));
 188: }
 189: 
 190: /*
 191:  * "shorthand"
 192:  */
 193: nameof(p)
 194: {
 195: 
 196:     return (clnames[classify(p)]);
 197: }
 198: 
 199: #ifndef PI0
 200: nowexp(r)
 201:     int *r;
 202: {
 203:     if (r[0] == T_WEXP) {
 204:         if (r[2] == NIL)
 205:             error("Oct/hex allowed only on writeln/write calls");
 206:         else
 207:             error("Width expressions allowed only in writeln/write calls");
 208:         return (1);
 209:     }
 210:     return (NIL);
 211: }
 212: #endif

Defined functions

Defined variables