123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314 |
- /*
- * (c) copyright 1987 by the Vrije Universiteit, Amsterdam, The Netherlands.
- * See the copyright notice in the ACK home directory, in the file "Copyright".
- *
- * Author: Ceriel J.H. Jacobs
- */
- /* T Y P E E Q U I V A L E N C E */
- /* $Id$ */
- /* Routines for testing type equivalence, type compatibility, and
- assignment compatibility
- */
- #include "debug.h"
- #include <em_arith.h>
- #include <em_label.h>
- #include <assert.h>
- #include "strict3rd.h"
- #include "type.h"
- #include "LLlex.h"
- #include "idf.h"
- #include "def.h"
- #include "node.h"
- #include "warning.h"
- #include "main.h"
- #include "Lpars.h"
- extern char *sprint();
- int
- TstTypeEquiv(tp1, tp2)
- t_type *tp1, *tp2;
- {
- /* test if two types are equivalent.
- */
- return tp1 == tp2
- ||
- tp1 == error_type
- ||
- tp2 == error_type;
- }
- int
- TstParEquiv(tp1, tp2)
- register t_type *tp1, *tp2;
- {
- /* test if two parameter types are equivalent. This routine
- is used to check if two different procedure declarations
- (one in the definition module, one in the implementation
- module) are equivalent. A complication comes from dynamic
- arrays.
- */
-
- return
- TstTypeEquiv(tp1, tp2)
- ||
- (
- IsConformantArray(tp1)
- &&
- IsConformantArray(tp2)
- &&
- TstTypeEquiv(tp1->arr_elem, tp2->arr_elem)
- );
- }
- int
- TstProcEquiv(tp1, tp2)
- t_type *tp1, *tp2;
- {
- /* Test if two procedure types are equivalent. This routine
- may also be used for the testing of assignment compatibility
- between procedure variables and procedures.
- */
- register t_param *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->par_next;
- p2 = p2->par_next;
- }
- /* Here, at least one of the parameterlists is exhausted.
- Check that they are both.
- */
- return p1 == p2;
- }
- int
- TstCompat(tp1, tp2)
- register t_type *tp1, *tp2;
- {
- /* test if two types are compatible. See section 6.3 of the
- Modula-2 Report for a definition of "compatible".
- */
- if (TstTypeEquiv(tp1, tp2)) return 1;
- tp1 = BaseType(tp1);
- tp2 = BaseType(tp2);
- if (tp2->tp_fund != T_INTORCARD &&
- (tp1->tp_fund == T_INTORCARD || tp1 == address_type)) {
- t_type *tmp = tp2;
-
- tp2 = tp1;
- tp1 = tmp;
- }
- return tp1 == tp2
- ||
- ( tp2 == intorcard_type
- &&
- (tp1 == int_type || tp1 == card_type || tp1 == address_type)
- )
- ||
- ( tp2 == longintorcard_type
- &&
- (tp1 == longint_type || tp1 == longcard_type || tp1 == address_type)
- )
- ||
- ( tp2 == address_type
- &&
- ( tp1->tp_fund == T_CARDINAL || tp1->tp_fund == T_POINTER)
- )
- ;
- }
- int
- TstAssCompat(tp1, tp2)
- register t_type *tp1, *tp2;
- {
- /* Test if two types are assignment compatible.
- See Def 9.1.
- */
- if (TstCompat(tp1, tp2)) return 1;
- tp1 = BaseType(tp1);
- tp2 = BaseType(tp2);
- if (((tp1->tp_fund & T_INTORCARD) || tp1 == address_type) &&
- ((tp2->tp_fund & T_INTORCARD) || tp2 == address_type)) return 1;
- if ((tp1->tp_fund == T_REAL) &&
- (tp2->tp_fund == T_REAL)) return 1;
- if (tp1->tp_fund == T_PROCEDURE &&
- tp2->tp_fund == T_PROCEDURE) {
- return TstProcEquiv(tp1, tp2);
- }
- if (tp1->tp_fund == T_ARRAY) {
- /* check for string
- */
- if (IsConformantArray(tp1)) return 0;
- return
- BaseType(tp1->arr_elem) == char_type
- && tp2->tp_fund == T_STRING
- && (tp1->arr_high - tp1->arr_low + 1) >= tp2->tp_size
- ;
- }
- return 0;
- }
- char *
- incompat(tp1, tp2)
- register t_type *tp1, *tp2;
- {
-
- if (tp1->tp_fund == T_HIDDEN || tp2->tp_fund == T_HIDDEN) {
- return "properties of opaque type are hidden; illegal use";
- }
- return "type incompatibility";
- }
- int
- TstParCompat(parno, formaltype, VARflag, nd, edf)
- register t_type *formaltype;
- t_node **nd;
- t_def *edf;
- {
- /* Check type compatibility for a parameter in a procedure call.
- Assignment compatibility may do if the parameter is
- a value parameter.
- Otherwise, a conformant array may do, or an ARRAY OF (WORD|BYTE)
- may do too.
- Or: a WORD may do.
- */
- register t_type *actualtype = (*nd)->nd_type;
- char ebuf[256];
- if (edf) {
- sprint(ebuf, "\"%s\", parameter %d: %%s", edf->df_idf->id_text, parno);
- }
- else sprint(ebuf, "parameter %d: %%s", parno);
- if (
- TstTypeEquiv(formaltype, actualtype)
- ||
- ( !VARflag && ChkAssCompat(nd, formaltype, (char *) 0))
- ||
- ( formaltype == address_type
- && actualtype->tp_fund == T_POINTER
- )
- ||
- ( formaltype == word_type
- &&
- ( actualtype->tp_size == word_size
- ||
- ( !VARflag
- &&
- actualtype->tp_size <= word_size
- &&
- ! IsConformantArray(actualtype)
- )
- )
- )
- ||
- ( formaltype == byte_type
- && actualtype->tp_size == (arith) 1
- )
- ||
- ( IsConformantArray(formaltype)
- &&
- ( formaltype->arr_elem == word_type
- || formaltype->arr_elem == byte_type
- ||
- ( actualtype->tp_fund == T_ARRAY
- && TstTypeEquiv(formaltype->arr_elem,actualtype->arr_elem)
- )
- ||
- ( actualtype->tp_fund == T_STRING
- && TstTypeEquiv(formaltype->arr_elem, char_type)
- )
- )
- )
- )
- return 1;
- #ifndef STRICT_3RD_ED
- if (! options['3'] && VARflag && TstCompat(formaltype, actualtype)) {
- if (formaltype->tp_size == actualtype->tp_size) {
- node_warning(*nd,
- W_OLDFASHIONED,
- ebuf,
- "identical types required");
- return 1;
- }
- node_error(*nd, ebuf, "equal sized types required");
- return 0;
- }
- #endif
- node_error(*nd, ebuf, incompat(formaltype, actualtype));
- return 0;
- }
- CompatCheck(nd, tp, message, fc)
- register t_node **nd;
- t_type *tp;
- char *message;
- int (*fc)();
- {
- if (! (*fc)(tp, (*nd)->nd_type)) {
- if (message) {
- node_error(*nd, "%s in %s",
- incompat(tp, (*nd)->nd_type),
- message);
- }
- return 0;
- }
- MkCoercion(nd, tp);
- return 1;
- }
- ChkAssCompat(nd, tp, message)
- t_node **nd;
- t_type *tp;
- char *message;
- {
- /* Check assignment compatibility of node "nd" with type "tp".
- Give an error message when it fails
- */
- if ((*nd)->nd_symb == STRING) {
- TryToString((*nd), tp);
- }
- return CompatCheck(nd, tp, message, TstAssCompat);
- }
- ChkCompat(nd, tp, message)
- t_node **nd;
- t_type *tp;
- char *message;
- {
- /* Check compatibility of node "nd" with type "tp".
- Give an error message when it fails
- */
- return CompatCheck(nd, tp, message, TstCompat);
- }
|