home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / bsd_srcs / usr.bin / pascal / src / clas.c < prev    next >
Encoding:
C/C++ Source or Header  |  1991-04-16  |  6.3 KB  |  300 lines
  1. /*-
  2.  * Copyright (c) 1980 The Regents of the University of California.
  3.  * All rights reserved.
  4.  *
  5.  * Redistribution and use in source and binary forms, with or without
  6.  * modification, are permitted provided that the following conditions
  7.  * are met:
  8.  * 1. Redistributions of source code must retain the above copyright
  9.  *    notice, this list of conditions and the following disclaimer.
  10.  * 2. Redistributions in binary form must reproduce the above copyright
  11.  *    notice, this list of conditions and the following disclaimer in the
  12.  *    documentation and/or other materials provided with the distribution.
  13.  * 3. All advertising materials mentioning features or use of this software
  14.  *    must display the following acknowledgement:
  15.  *    This product includes software developed by the University of
  16.  *    California, Berkeley and its contributors.
  17.  * 4. Neither the name of the University nor the names of its contributors
  18.  *    may be used to endorse or promote products derived from this software
  19.  *    without specific prior written permission.
  20.  *
  21.  * THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND
  22.  * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
  23.  * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
  24.  * ARE DISCLAIMED.  IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE
  25.  * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
  26.  * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
  27.  * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
  28.  * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
  29.  * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
  30.  * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
  31.  * SUCH DAMAGE.
  32.  */
  33.  
  34. #ifndef lint
  35. static char sccsid[] = "@(#)clas.c    5.3 (Berkeley) 4/16/91";
  36. #endif /* not lint */
  37.  
  38. #include "whoami.h"
  39. #include "0.h"
  40. #include "tree.h"
  41. #include "tree_ty.h"
  42.  
  43. /*
  44.  * This is the array of class
  45.  * names for the classes returned
  46.  * by classify.  The order of the 
  47.  * classes is the same as the base
  48.  * of the namelist, with special
  49.  * negative index entries for structures,
  50.  * scalars, pointers, sets and strings
  51.  * to be collapsed into.
  52.  */
  53. char    *clnxxxx[] =
  54. {
  55.     "file",            /* -7    TFILE */
  56.     "record",        /* -6    TREC */
  57.     "array",        /* -5    TARY */
  58.     "scalar",        /* -4    TSCAL */
  59.     "pointer",        /* -3    TPTR */
  60.     "set",            /* -2    TSET */
  61.     "string",        /* -1    TSTR */
  62.     "SNARK",        /*  0    NIL */
  63.     "Boolean",        /*  1    TBOOL */
  64.     "char",            /*  2    TCHAR */
  65.     "integer",        /*  3    TINT */
  66.     "real",            /*  4    TREAL */
  67.     "\"nil\"",        /*  5    TNIL */
  68. };
  69.  
  70. char **clnames    = &clnxxxx[-(TFIRST)];
  71.  
  72. /*
  73.  * Classify takes a pointer
  74.  * to a type and returns one
  75.  * of several interesting group
  76.  * classifications for easy use.
  77.  */
  78. classify(p1)
  79.     struct nl *p1;
  80. {
  81.     register struct nl *p;
  82.  
  83.     p = p1;
  84. swit:
  85.     if (p == NLNIL) {
  86.         nocascade();
  87.         return (NIL);
  88.     }
  89.     if (p == &nl[TSTR])
  90.         return (TSTR);
  91.     if ( p == &nl[ TSET ] ) {
  92.         return TSET;
  93.     }
  94.     switch (p->class) {
  95.         case PTR:
  96.             return (TPTR);
  97.         case ARRAY:
  98.             if (p->type == nl+T1CHAR)
  99.                 return (TSTR);
  100.             return (TARY);
  101.         case STR:
  102.             return (TSTR);
  103.         case SET:
  104.             return (TSET);
  105.         case CRANGE:
  106.         case RANGE:
  107.             p = p->type;
  108.             goto swit;
  109.         case TYPE:
  110.             if (p <= nl+TLAST)
  111.                 return (p - nl);
  112.             panic("clas2");
  113.         case FILET:
  114.             return (TFILE);
  115.         case RECORD:
  116.             return (TREC);
  117.         case SCAL:
  118.             return (TSCAL);
  119.         default:
  120.             {
  121.                 panic("clas");
  122.                 return(NIL);
  123.             }
  124.     }
  125. }
  126.  
  127. #ifndef    PI0
  128. /*
  129.  * Is p a text file?
  130.  */
  131. text(p)
  132.     struct nl *p;
  133. {
  134.  
  135.     return (p != NIL && p->class == FILET && p->type == nl+T1CHAR);
  136. }
  137. #endif
  138.  
  139. /*
  140.  * Scalar returns a pointer to
  141.  * the the base scalar type of
  142.  * its argument if its argument
  143.  * is a SCALar else NIL.
  144.  */
  145. struct nl *
  146. scalar(p1)
  147.     struct nl *p1;
  148. {
  149.     register struct nl *p;
  150.  
  151.     p = p1;
  152.     if (p == NLNIL)
  153.         return (NLNIL);
  154.     if (p->class == RANGE || p->class == CRANGE)
  155.         p = p->type;
  156.     if (p == NLNIL)
  157.         return (NLNIL);
  158.     return (p->class == SCAL ? p : NLNIL);
  159. }
  160.  
  161. /*
  162.  * Isa tells whether p
  163.  * is one of a group of
  164.  * namelist classes.  The
  165.  * classes wanted are specified
  166.  * by the characters in s.
  167.  * (Note that s would more efficiently,
  168.  * if less clearly, be given by a mask.)
  169.  */
  170. isa(p, s)
  171.     register struct nl *p;
  172.     char *s;
  173. {
  174.     register i;
  175.     register char *cp;
  176.  
  177.     if (p == NIL)
  178.         return (NIL);
  179.     /*
  180.      * map ranges down to
  181.      * the base type
  182.      */
  183.     if (p->class == RANGE) {
  184.         p = p->type;
  185.     }
  186.     /*
  187.      * the following character/class
  188.      * associations are made:
  189.      *
  190.      *    s    scalar
  191.      *    b    Boolean
  192.      *    c    character
  193.      *    i    integer
  194.      *    d    double (real)
  195.      *    t    set
  196.      */
  197.     switch (p->class) {
  198.         case SET:
  199.             i = TDOUBLE+1;
  200.             break;
  201.         case SCAL:
  202.             i = 0;
  203.             break;
  204.         case CRANGE:
  205.             /*
  206.              * find the base type of a conformant array range
  207.              */
  208.             switch (classify(p->type)) {
  209.                 case TBOOL: i = 1; break;
  210.                 case TCHAR: i = 2; break;
  211.                 case TINT: i = 3; break;
  212.                 case TSCAL: i = 0; break;
  213.                 default:
  214.                     panic( "isa" );
  215.             }
  216.             break;
  217.         default:
  218.             i = p - nl;
  219.     }
  220.     if (i >= 0 && i <= TDOUBLE+1) {
  221.         i = "sbcidt"[i];
  222.         cp = s;
  223.         while (*cp)
  224.             if (*cp++ == i)
  225.                 return (1);
  226.     }
  227.     return (NIL);
  228. }
  229.  
  230. /*
  231.  * Isnta is !isa
  232.  */
  233. isnta(p, s)
  234.     struct nl *p;
  235.     char *s;
  236. {
  237.  
  238.     return (!isa(p, s));
  239. }
  240.  
  241. /*
  242.  * "shorthand"
  243.  */
  244. char *
  245. nameof(p)
  246. struct nl *p;
  247. {
  248.  
  249.     return (clnames[classify(p)]);
  250. }
  251.  
  252. #ifndef PI0
  253. /* find out for sure what kind of node this is being passed
  254.    possibly several different kinds of node are passed to it */
  255. int nowexp(r)
  256.     struct tnode *r;
  257. {
  258.     if (r->tag == T_WEXP) {
  259.         if (r->var_node.cptr == NIL)
  260.             error("Oct/hex allowed only on writeln/write calls");
  261.         else
  262.             error("Width expressions allowed only in writeln/write calls");
  263.         return (1);
  264.     }
  265.     return (NIL);
  266. }
  267. #endif
  268.  
  269.     /*
  270.      *    is a variable a local, a formal parameter, or a global?
  271.      *    all this from just the offset:
  272.      *        globals are at levels 0 or 1
  273.      *        positives are parameters
  274.      *        negative evens are locals
  275.      */
  276. /*ARGSUSED*/
  277. whereis( offset , other_flags )
  278.     int        offset;
  279.     char    other_flags;
  280. {
  281.     
  282. #   ifdef OBJ
  283.     return ( offset >= 0 ? PARAMVAR : LOCALVAR );
  284. #   endif OBJ
  285. #   ifdef PC
  286.     switch ( other_flags & ( NGLOBAL | NPARAM | NLOCAL | NNLOCAL) ) {
  287.         default:
  288.         panic( "whereis" );
  289.         case NGLOBAL:
  290.         return GLOBALVAR;
  291.         case NPARAM:
  292.         return PARAMVAR;
  293.         case NNLOCAL:
  294.         return NAMEDLOCALVAR;
  295.         case NLOCAL:
  296.         return LOCALVAR;
  297.     }
  298. #   endif PC
  299. }
  300.