123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300 |
- /* T Y P E E Q U I V A L E N C E */
- /* Routines for testing type equivalence & type compatibility.
- */
- #include "debug.h"
- #include <assert.h>
- #include <em_arith.h>
- #include <em_label.h>
- #include "LLlex.h"
- #include "def.h"
- #include "node.h"
- #include "type.h"
- int
- TstTypeEquiv(tp1, tp2)
- register struct type *tp1, *tp2;
- {
- /* test if two types are equivalent.
- */
- return tp1 == tp2 || tp1 == error_type || tp2 == error_type;
- }
- arith
- IsString(tp)
- register struct type *tp;
- {
- /* string = packed array[1..ub] of char and ub > 1 */
- if( tp->tp_fund & T_STRINGCONST ) return tp->tp_psize;
- if( IsConformantArray(tp) ) return 0;
- if( tp->tp_fund & T_ARRAY && IsPacked(tp) &&
- tp->arr_elem == char_type ) {
- arith lb, ub;
- if( BaseType(IndexType(tp)) != int_type ) return 0;
- getbounds(IndexType(tp), &lb, &ub);
- return (lb == 1 && ub > 1) ? ub : (arith) 0;
- }
- return (arith) 0;
- }
- int
- TstStrCompat(tp1, tp2)
- register struct type *tp1, *tp2;
- {
- /* test if two types are compatible string-types.
- */
- arith ub1, ub2;
- ub1 = IsString(tp1);
- ub2 = IsString(tp2);
- if( !ub1 || !ub2 ) return 0;
- else
- return ub1 == ub2;
- }
- int
- TstCompat(tp1, tp2)
- register struct type *tp1, *tp2;
- {
- /* test if two types are compatible. ISO 6.4.5
- */
- /* clause a */
- if( TstTypeEquiv(tp1, tp2) ) return 1;
- /* clause d */
- if( TstStrCompat(tp1, tp2) ) return 1;
- /* type of NIL is compatible with every pointertype */
- if( tp1->tp_fund & T_POINTER && tp2->tp_fund & T_POINTER )
- return tp1 == tp2 || tp1 == nil_type || tp2 == nil_type;
- /* clause c */
- /* if both types are sets then both must be packed or not */
- if( tp1->tp_fund & T_SET && tp2->tp_fund & T_SET ) {
- if( tp1 == emptyset_type || tp2 == emptyset_type )
- return 1;
- if( IsPacked(tp1) != IsPacked(tp2) )
- return 0;
- if( TstCompat(ElementType(tp1), ElementType(tp2)) ) {
- /*
- if( ElementType(tp1) != ElementType(tp2) )
- warning("base-types of sets not equal");
- */
- return 1;
- }
- else return 0;
- }
- /* no clause, just check for longs and ints */
- /* BaseType is used in case of array indexing */
- if ((BaseType(tp1) == int_type && tp2 == long_type) ||
- (tp1 == long_type && BaseType(tp2) == int_type))
- return 1;
- /* clause b */
- tp1 = BaseType(tp1);
- tp2 = BaseType(tp2);
- return tp1 == tp2;
- }
- int
- TstAssCompat(tp1, tp2)
- register struct type *tp1, *tp2;
- {
- /* test if two types are assignment compatible. ISO 6.4.6
- */
- /* clauses a, c, d and e */
- if( TstCompat(tp1, tp2) )
- return !(tp1->tp_flags & T_HASFILE);
- /* clause b */
- if( tp1 == real_type )
- return BaseType(tp2) == int_type || BaseType(tp2) == long_type;
- return 0;
- }
- int
- TstParEquiv(tp1, tp2)
- register struct type *tp1, *tp2;
- {
- /* Test if two parameter types are equivalent. ISO 6.6.3.6
- */
-
- return
- TstTypeEquiv(tp1, tp2)
- ||
- (
- IsConformantArray(tp1)
- &&
- IsConformantArray(tp2)
- &&
- IsPacked(tp1) == IsPacked(tp2)
- &&
- TstParEquiv(tp1->arr_elem, tp2->arr_elem)
- )
- ||
- (
- (
- tp1->tp_fund == T_PROCEDURE && tp2->tp_fund == T_PROCEDURE
- ||
- tp1->tp_fund == T_FUNCTION && tp2->tp_fund == T_FUNCTION
- )
- &&
- TstProcEquiv(tp1, tp2)
- );
- }
- int
- TstProcEquiv(tp1, tp2)
- register struct type *tp1, *tp2;
- {
- /* Test if two procedure types are equivalent. ISO 6.6.3.6
- */
- register struct paramlist *p1, *p2;
- /* First check if the result types are equivalent
- */
- if( !TstTypeEquiv(ResultType(tp1), ResultType(tp2)) )
- return 0;
- p1 = ParamList(tp1);
- p2 = ParamList(tp2);
- /* Now check the parameters
- */
- while( p1 && p2 ) {
- if( IsVarParam(p1) != IsVarParam(p2) ||
- !TstParEquiv(TypeOfParam(p1), TypeOfParam(p2)) ) return 0;
- p1 = p1->next;
- p2 = p2->next;
- }
- /* Here, at least one of the parameterlists is exhausted.
- Check that they are both.
- */
- return p1 == p2;
- }
- int
- TstParCompat(formaltype, actualtype, VARflag, nd, new_par_section)
- register struct type *formaltype, *actualtype;
- struct node *nd;
- {
- /* Check type compatibility for a parameter in a procedure call.
- */
- if(
- TstTypeEquiv(formaltype, actualtype)
- ||
- ( !VARflag && TstAssCompat(formaltype, actualtype) )
- ||
- ( formaltype->tp_fund == T_FUNCTION
- &&
- actualtype->tp_fund == T_FUNCTION
- &&
- TstProcEquiv(formaltype, actualtype)
- )
- ||
- ( formaltype->tp_fund == T_PROCEDURE
- &&
- actualtype->tp_fund == T_PROCEDURE
- &&
- TstProcEquiv(formaltype, actualtype)
- )
- ||
- ( IsConformantArray(formaltype)
- &&
- TstConform(formaltype, actualtype, new_par_section)
- )
- ) {
- if( !VARflag && IsConformantArray(actualtype) ) {
- node_warning(nd,
- "conformant array used as value parameter");
- }
- return 1;
- }
- else return 0;
- }
- int
- TstConform(formaltype, actualtype, new_par_section)
- register struct type *formaltype, *actualtype;
- {
- /* Check conformability.
-
- DEVIATION FROM STANDARD (ISO 6.6.3.7.2):
- Allow with value parameters also conformant arrays as actual
- type.(ISO only with var. parameters)
- Do as much checking on indextypes as possible.
- */
- struct type *formalindextp, *actualindextp;
- arith flb, fub, alb, aub;
- static struct type *lastactual;
- if( !new_par_section )
- /* actualparameters of one conformant-array-specification
- must be equal
- */
- return TstTypeEquiv(actualtype, lastactual);
- lastactual = actualtype;
- if( actualtype->tp_fund == T_STRINGCONST ) {
- actualindextp = int_type;
- alb = 1;
- aub = actualtype->tp_psize;
- }
- else if( actualtype->tp_fund == T_ARRAY ) {
- actualindextp = IndexType(actualtype);
- if( bounded(actualindextp) )
- getbounds(actualindextp, &alb, &aub);
- }
- else
- return 0;
- /* clause (d) */
- if( IsPacked(actualtype) != IsPacked(formaltype) )
- return 0;
- formalindextp = IndexType(formaltype);
- /* clause (a) */
- if( !TstCompat(actualindextp, formalindextp) )
- return 0;
- /* clause (b) */
- if( bounded(actualindextp) ||
- actualindextp->tp_fund == T_STRINGCONST ) {
- /* test was necessary because the actual type could be confor-
- mant !!
- */
- if( bounded(formalindextp) ) {
- getbounds(formalindextp, &flb, &fub);
- if( alb < flb || aub > fub )
- return 0;
- }
- }
- /* clause (c) */
- if( !IsConformantArray(formaltype->arr_elem) )
- return TstTypeEquiv(actualtype->arr_elem, formaltype->arr_elem);
- else
- return TstConform(formaltype->arr_elem, actualtype->arr_elem,
- new_par_section);
- }
|