4.4BSD/usr/src/usr.bin/pascal/src/clas.c
/*-
* Copyright (c) 1980, 1993
* The Regents of the University of California. All rights reserved.
*
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions
* are met:
* 1. Redistributions of source code must retain the above copyright
* notice, this list of conditions and the following disclaimer.
* 2. Redistributions in binary form must reproduce the above copyright
* notice, this list of conditions and the following disclaimer in the
* documentation and/or other materials provided with the distribution.
* 3. All advertising materials mentioning features or use of this software
* must display the following acknowledgement:
* This product includes software developed by the University of
* California, Berkeley and its contributors.
* 4. Neither the name of the University nor the names of its contributors
* may be used to endorse or promote products derived from this software
* without specific prior written permission.
*
* THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND
* ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
* IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
* ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE
* FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
* DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
* OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
* HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
* LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
* OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
* SUCH DAMAGE.
*/
#ifndef lint
static char sccsid[] = "@(#)clas.c 8.1 (Berkeley) 6/6/93";
#endif /* not lint */
#include "whoami.h"
#include "0.h"
#include "tree.h"
#include "tree_ty.h"
/*
* This is the array of class
* names for the classes returned
* by classify. The order of the
* classes is the same as the base
* of the namelist, with special
* negative index entries for structures,
* scalars, pointers, sets and strings
* to be collapsed into.
*/
char *clnxxxx[] =
{
"file", /* -7 TFILE */
"record", /* -6 TREC */
"array", /* -5 TARY */
"scalar", /* -4 TSCAL */
"pointer", /* -3 TPTR */
"set", /* -2 TSET */
"string", /* -1 TSTR */
"SNARK", /* 0 NIL */
"Boolean", /* 1 TBOOL */
"char", /* 2 TCHAR */
"integer", /* 3 TINT */
"real", /* 4 TREAL */
"\"nil\"", /* 5 TNIL */
};
char **clnames = &clnxxxx[-(TFIRST)];
/*
* Classify takes a pointer
* to a type and returns one
* of several interesting group
* classifications for easy use.
*/
classify(p1)
struct nl *p1;
{
register struct nl *p;
p = p1;
swit:
if (p == NLNIL) {
nocascade();
return (NIL);
}
if (p == &nl[TSTR])
return (TSTR);
if ( p == &nl[ TSET ] ) {
return TSET;
}
switch (p->class) {
case PTR:
return (TPTR);
case ARRAY:
if (p->type == nl+T1CHAR)
return (TSTR);
return (TARY);
case STR:
return (TSTR);
case SET:
return (TSET);
case CRANGE:
case RANGE:
p = p->type;
goto swit;
case TYPE:
if (p <= nl+TLAST)
return (p - nl);
panic("clas2");
case FILET:
return (TFILE);
case RECORD:
return (TREC);
case SCAL:
return (TSCAL);
default:
{
panic("clas");
return(NIL);
}
}
}
#ifndef PI0
/*
* Is p a text file?
*/
text(p)
struct nl *p;
{
return (p != NIL && p->class == FILET && p->type == nl+T1CHAR);
}
#endif
/*
* Scalar returns a pointer to
* the the base scalar type of
* its argument if its argument
* is a SCALar else NIL.
*/
struct nl *
scalar(p1)
struct nl *p1;
{
register struct nl *p;
p = p1;
if (p == NLNIL)
return (NLNIL);
if (p->class == RANGE || p->class == CRANGE)
p = p->type;
if (p == NLNIL)
return (NLNIL);
return (p->class == SCAL ? p : NLNIL);
}
/*
* Isa tells whether p
* is one of a group of
* namelist classes. The
* classes wanted are specified
* by the characters in s.
* (Note that s would more efficiently,
* if less clearly, be given by a mask.)
*/
isa(p, s)
register struct nl *p;
char *s;
{
register i;
register char *cp;
if (p == NIL)
return (NIL);
/*
* map ranges down to
* the base type
*/
if (p->class == RANGE) {
p = p->type;
}
/*
* the following character/class
* associations are made:
*
* s scalar
* b Boolean
* c character
* i integer
* d double (real)
* t set
*/
switch (p->class) {
case SET:
i = TDOUBLE+1;
break;
case SCAL:
i = 0;
break;
case CRANGE:
/*
* find the base type of a conformant array range
*/
switch (classify(p->type)) {
case TBOOL: i = 1; break;
case TCHAR: i = 2; break;
case TINT: i = 3; break;
case TSCAL: i = 0; break;
default:
panic( "isa" );
}
break;
default:
i = p - nl;
}
if (i >= 0 && i <= TDOUBLE+1) {
i = "sbcidt"[i];
cp = s;
while (*cp)
if (*cp++ == i)
return (1);
}
return (NIL);
}
/*
* Isnta is !isa
*/
isnta(p, s)
struct nl *p;
char *s;
{
return (!isa(p, s));
}
/*
* "shorthand"
*/
char *
nameof(p)
struct nl *p;
{
return (clnames[classify(p)]);
}
#ifndef PI0
/* find out for sure what kind of node this is being passed
possibly several different kinds of node are passed to it */
int nowexp(r)
struct tnode *r;
{
if (r->tag == T_WEXP) {
if (r->var_node.cptr == NIL)
error("Oct/hex allowed only on writeln/write calls");
else
error("Width expressions allowed only in writeln/write calls");
return (1);
}
return (NIL);
}
#endif
/*
* is a variable a local, a formal parameter, or a global?
* all this from just the offset:
* globals are at levels 0 or 1
* positives are parameters
* negative evens are locals
*/
/*ARGSUSED*/
whereis( offset , other_flags )
int offset;
char other_flags;
{
# ifdef OBJ
return ( offset >= 0 ? PARAMVAR : LOCALVAR );
# endif OBJ
# ifdef PC
switch ( other_flags & ( NGLOBAL | NPARAM | NLOCAL | NNLOCAL) ) {
default:
panic( "whereis" );
case NGLOBAL:
return GLOBALVAR;
case NPARAM:
return PARAMVAR;
case NNLOCAL:
return NAMEDLOCALVAR;
case NLOCAL:
return LOCALVAR;
}
# endif PC
}