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