typequiv.c 6.3 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300
  1. /* T Y P E E Q U I V A L E N C E */
  2. /* Routines for testing type equivalence & type compatibility.
  3. */
  4. #include "debug.h"
  5. #include <assert.h>
  6. #include <em_arith.h>
  7. #include <em_label.h>
  8. #include "LLlex.h"
  9. #include "def.h"
  10. #include "node.h"
  11. #include "type.h"
  12. int
  13. TstTypeEquiv(tp1, tp2)
  14. register struct type *tp1, *tp2;
  15. {
  16. /* test if two types are equivalent.
  17. */
  18. return tp1 == tp2 || tp1 == error_type || tp2 == error_type;
  19. }
  20. arith
  21. IsString(tp)
  22. register struct type *tp;
  23. {
  24. /* string = packed array[1..ub] of char and ub > 1 */
  25. if( tp->tp_fund & T_STRINGCONST ) return tp->tp_psize;
  26. if( IsConformantArray(tp) ) return 0;
  27. if( tp->tp_fund & T_ARRAY && IsPacked(tp) &&
  28. tp->arr_elem == char_type ) {
  29. arith lb, ub;
  30. if( BaseType(IndexType(tp)) != int_type ) return 0;
  31. getbounds(IndexType(tp), &lb, &ub);
  32. return (lb == 1 && ub > 1) ? ub : (arith) 0;
  33. }
  34. return (arith) 0;
  35. }
  36. int
  37. TstStrCompat(tp1, tp2)
  38. register struct type *tp1, *tp2;
  39. {
  40. /* test if two types are compatible string-types.
  41. */
  42. arith ub1, ub2;
  43. ub1 = IsString(tp1);
  44. ub2 = IsString(tp2);
  45. if( !ub1 || !ub2 ) return 0;
  46. else
  47. return ub1 == ub2;
  48. }
  49. int
  50. TstCompat(tp1, tp2)
  51. register struct type *tp1, *tp2;
  52. {
  53. /* test if two types are compatible. ISO 6.4.5
  54. */
  55. /* clause a */
  56. if( TstTypeEquiv(tp1, tp2) ) return 1;
  57. /* clause d */
  58. if( TstStrCompat(tp1, tp2) ) return 1;
  59. /* type of NIL is compatible with every pointertype */
  60. if( tp1->tp_fund & T_POINTER && tp2->tp_fund & T_POINTER )
  61. return tp1 == tp2 || tp1 == nil_type || tp2 == nil_type;
  62. /* clause c */
  63. /* if both types are sets then both must be packed or not */
  64. if( tp1->tp_fund & T_SET && tp2->tp_fund & T_SET ) {
  65. if( tp1 == emptyset_type || tp2 == emptyset_type )
  66. return 1;
  67. if( IsPacked(tp1) != IsPacked(tp2) )
  68. return 0;
  69. if( TstCompat(ElementType(tp1), ElementType(tp2)) ) {
  70. /*
  71. if( ElementType(tp1) != ElementType(tp2) )
  72. warning("base-types of sets not equal");
  73. */
  74. return 1;
  75. }
  76. else return 0;
  77. }
  78. /* no clause, just check for longs and ints */
  79. /* BaseType is used in case of array indexing */
  80. if ((BaseType(tp1) == int_type && tp2 == long_type) ||
  81. (tp1 == long_type && BaseType(tp2) == int_type))
  82. return 1;
  83. /* clause b */
  84. tp1 = BaseType(tp1);
  85. tp2 = BaseType(tp2);
  86. return tp1 == tp2;
  87. }
  88. int
  89. TstAssCompat(tp1, tp2)
  90. register struct type *tp1, *tp2;
  91. {
  92. /* test if two types are assignment compatible. ISO 6.4.6
  93. */
  94. /* clauses a, c, d and e */
  95. if( TstCompat(tp1, tp2) )
  96. return !(tp1->tp_flags & T_HASFILE);
  97. /* clause b */
  98. if( tp1 == real_type )
  99. return BaseType(tp2) == int_type || BaseType(tp2) == long_type;
  100. return 0;
  101. }
  102. int
  103. TstParEquiv(tp1, tp2)
  104. register struct type *tp1, *tp2;
  105. {
  106. /* Test if two parameter types are equivalent. ISO 6.6.3.6
  107. */
  108. return
  109. TstTypeEquiv(tp1, tp2)
  110. ||
  111. (
  112. IsConformantArray(tp1)
  113. &&
  114. IsConformantArray(tp2)
  115. &&
  116. IsPacked(tp1) == IsPacked(tp2)
  117. &&
  118. TstParEquiv(tp1->arr_elem, tp2->arr_elem)
  119. )
  120. ||
  121. (
  122. (
  123. tp1->tp_fund == T_PROCEDURE && tp2->tp_fund == T_PROCEDURE
  124. ||
  125. tp1->tp_fund == T_FUNCTION && tp2->tp_fund == T_FUNCTION
  126. )
  127. &&
  128. TstProcEquiv(tp1, tp2)
  129. );
  130. }
  131. int
  132. TstProcEquiv(tp1, tp2)
  133. register struct type *tp1, *tp2;
  134. {
  135. /* Test if two procedure types are equivalent. ISO 6.6.3.6
  136. */
  137. register struct paramlist *p1, *p2;
  138. /* First check if the result types are equivalent
  139. */
  140. if( !TstTypeEquiv(ResultType(tp1), ResultType(tp2)) )
  141. return 0;
  142. p1 = ParamList(tp1);
  143. p2 = ParamList(tp2);
  144. /* Now check the parameters
  145. */
  146. while( p1 && p2 ) {
  147. if( IsVarParam(p1) != IsVarParam(p2) ||
  148. !TstParEquiv(TypeOfParam(p1), TypeOfParam(p2)) ) return 0;
  149. p1 = p1->next;
  150. p2 = p2->next;
  151. }
  152. /* Here, at least one of the parameterlists is exhausted.
  153. Check that they are both.
  154. */
  155. return p1 == p2;
  156. }
  157. int
  158. TstParCompat(formaltype, actualtype, VARflag, nd, new_par_section)
  159. register struct type *formaltype, *actualtype;
  160. struct node *nd;
  161. {
  162. /* Check type compatibility for a parameter in a procedure call.
  163. */
  164. if(
  165. TstTypeEquiv(formaltype, actualtype)
  166. ||
  167. ( !VARflag && TstAssCompat(formaltype, actualtype) )
  168. ||
  169. ( formaltype->tp_fund == T_FUNCTION
  170. &&
  171. actualtype->tp_fund == T_FUNCTION
  172. &&
  173. TstProcEquiv(formaltype, actualtype)
  174. )
  175. ||
  176. ( formaltype->tp_fund == T_PROCEDURE
  177. &&
  178. actualtype->tp_fund == T_PROCEDURE
  179. &&
  180. TstProcEquiv(formaltype, actualtype)
  181. )
  182. ||
  183. ( IsConformantArray(formaltype)
  184. &&
  185. TstConform(formaltype, actualtype, new_par_section)
  186. )
  187. ) {
  188. if( !VARflag && IsConformantArray(actualtype) ) {
  189. node_warning(nd,
  190. "conformant array used as value parameter");
  191. }
  192. return 1;
  193. }
  194. else return 0;
  195. }
  196. int
  197. TstConform(formaltype, actualtype, new_par_section)
  198. register struct type *formaltype, *actualtype;
  199. {
  200. /* Check conformability.
  201. DEVIATION FROM STANDARD (ISO 6.6.3.7.2):
  202. Allow with value parameters also conformant arrays as actual
  203. type.(ISO only with var. parameters)
  204. Do as much checking on indextypes as possible.
  205. */
  206. struct type *formalindextp, *actualindextp;
  207. arith flb, fub, alb, aub;
  208. static struct type *lastactual;
  209. if( !new_par_section )
  210. /* actualparameters of one conformant-array-specification
  211. must be equal
  212. */
  213. return TstTypeEquiv(actualtype, lastactual);
  214. lastactual = actualtype;
  215. if( actualtype->tp_fund == T_STRINGCONST ) {
  216. actualindextp = int_type;
  217. alb = 1;
  218. aub = actualtype->tp_psize;
  219. }
  220. else if( actualtype->tp_fund == T_ARRAY ) {
  221. actualindextp = IndexType(actualtype);
  222. if( bounded(actualindextp) )
  223. getbounds(actualindextp, &alb, &aub);
  224. }
  225. else
  226. return 0;
  227. /* clause (d) */
  228. if( IsPacked(actualtype) != IsPacked(formaltype) )
  229. return 0;
  230. formalindextp = IndexType(formaltype);
  231. /* clause (a) */
  232. if( !TstCompat(actualindextp, formalindextp) )
  233. return 0;
  234. /* clause (b) */
  235. if( bounded(actualindextp) ||
  236. actualindextp->tp_fund == T_STRINGCONST ) {
  237. /* test was necessary because the actual type could be confor-
  238. mant !!
  239. */
  240. if( bounded(formalindextp) ) {
  241. getbounds(formalindextp, &flb, &fub);
  242. if( alb < flb || aub > fub )
  243. return 0;
  244. }
  245. }
  246. /* clause (c) */
  247. if( !IsConformantArray(formaltype->arr_elem) )
  248. return TstTypeEquiv(actualtype->arr_elem, formaltype->arr_elem);
  249. else
  250. return TstConform(formaltype->arr_elem, actualtype->arr_elem,
  251. new_par_section);
  252. }