typequiv.c 6.0 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291
  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_STRING ) 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. if( ElementType(tp1) != ElementType(tp2) )
  71. warning("base-types of sets not equal");
  72. return 1;
  73. }
  74. else return 0;
  75. }
  76. /* clause b */
  77. tp1 = BaseType(tp1);
  78. tp2 = BaseType(tp2);
  79. return tp1 == tp2;
  80. }
  81. int
  82. TstAssCompat(tp1, tp2)
  83. register struct type *tp1, *tp2;
  84. {
  85. /* test if two types are assignment compatible. ISO 6.4.6
  86. */
  87. /* clauses a, c, d and e */
  88. if( TstCompat(tp1, tp2) )
  89. return !(tp1->tp_flags & T_HASFILE);
  90. /* clause b */
  91. if( tp1 == real_type )
  92. return BaseType(tp2) == int_type;
  93. return 0;
  94. }
  95. int
  96. TstParEquiv(tp1, tp2)
  97. register struct type *tp1, *tp2;
  98. {
  99. /* Test if two parameter types are equivalent. ISO 6.6.3.6
  100. */
  101. return
  102. TstTypeEquiv(tp1, tp2)
  103. ||
  104. (
  105. IsConformantArray(tp1)
  106. &&
  107. IsConformantArray(tp2)
  108. &&
  109. IsPacked(tp1) == IsPacked(tp2)
  110. &&
  111. TstParEquiv(tp1->arr_elem, tp2->arr_elem)
  112. )
  113. ||
  114. (
  115. (
  116. tp1->tp_fund == T_PROCEDURE && tp2->tp_fund == T_PROCEDURE
  117. ||
  118. tp1->tp_fund == T_FUNCTION && tp2->tp_fund == T_FUNCTION
  119. )
  120. &&
  121. TstProcEquiv(tp1, tp2)
  122. );
  123. }
  124. int
  125. TstProcEquiv(tp1, tp2)
  126. register struct type *tp1, *tp2;
  127. {
  128. /* Test if two procedure types are equivalent. ISO 6.6.3.6
  129. */
  130. register struct paramlist *p1, *p2;
  131. /* First check if the result types are equivalent
  132. */
  133. if( !TstTypeEquiv(ResultType(tp1), ResultType(tp2)) )
  134. return 0;
  135. p1 = ParamList(tp1);
  136. p2 = ParamList(tp2);
  137. /* Now check the parameters
  138. */
  139. while( p1 && p2 ) {
  140. if( IsVarParam(p1) != IsVarParam(p2) ||
  141. !TstParEquiv(TypeOfParam(p1), TypeOfParam(p2)) ) return 0;
  142. p1 = p1->next;
  143. p2 = p2->next;
  144. }
  145. /* Here, at least one of the parameterlists is exhausted.
  146. Check that they are both.
  147. */
  148. return p1 == p2;
  149. }
  150. int
  151. TstParCompat(formaltype, actualtype, VARflag, nd, new_par_section)
  152. register struct type *formaltype, *actualtype;
  153. struct node *nd;
  154. {
  155. /* Check type compatibility for a parameter in a procedure call.
  156. */
  157. if(
  158. TstTypeEquiv(formaltype, actualtype)
  159. ||
  160. ( !VARflag && TstAssCompat(formaltype, actualtype) )
  161. ||
  162. ( formaltype->tp_fund == T_FUNCTION
  163. &&
  164. actualtype->tp_fund == T_FUNCTION
  165. &&
  166. TstProcEquiv(formaltype, actualtype)
  167. )
  168. ||
  169. ( formaltype->tp_fund == T_PROCEDURE
  170. &&
  171. actualtype->tp_fund == T_PROCEDURE
  172. &&
  173. TstProcEquiv(formaltype, actualtype)
  174. )
  175. ||
  176. ( IsConformantArray(formaltype)
  177. &&
  178. TstConform(formaltype, actualtype, new_par_section)
  179. )
  180. ) {
  181. if( !VARflag && IsConformantArray(actualtype) ) {
  182. node_warning(nd,
  183. "conformant array used as value parameter");
  184. }
  185. return 1;
  186. }
  187. else return 0;
  188. }
  189. int
  190. TstConform(formaltype, actualtype, new_par_section)
  191. register struct type *formaltype, *actualtype;
  192. {
  193. /* Check conformability.
  194. DEVIATION FROM STANDARD (ISO 6.6.3.7.2):
  195. Allow with value parameters also conformant arrays as actual
  196. type.(ISO only with var. parameters)
  197. Do as much checking on indextypes as possible.
  198. */
  199. struct type *formalindextp, *actualindextp;
  200. arith flb, fub, alb, aub;
  201. static struct type *lastactual;
  202. if( !new_par_section )
  203. /* actualparameters of one conformant-array-specification
  204. must be equal
  205. */
  206. return TstTypeEquiv(actualtype, lastactual);
  207. lastactual = actualtype;
  208. if( actualtype->tp_fund == T_STRING ) {
  209. actualindextp = int_type;
  210. alb = 1;
  211. aub = actualtype->tp_psize;
  212. }
  213. else if( actualtype->tp_fund == T_ARRAY ) {
  214. actualindextp = IndexType(actualtype);
  215. if( bounded(actualindextp) )
  216. getbounds(actualindextp, &alb, &aub);
  217. }
  218. else
  219. return 0;
  220. /* clause (d) */
  221. if( IsPacked(actualtype) != IsPacked(formaltype) )
  222. return 0;
  223. formalindextp = IndexType(formaltype);
  224. /* clause (a) */
  225. if( !TstCompat(actualindextp, formalindextp) )
  226. return 0;
  227. /* clause (b) */
  228. if( bounded(actualindextp) || actualindextp->tp_fund == T_STRING ) {
  229. /* test was necessary because the actual type could be confor-
  230. mant !!
  231. */
  232. if( bounded(formalindextp) ) {
  233. getbounds(formalindextp, &flb, &fub);
  234. if( alb < flb || aub > fub )
  235. return 0;
  236. }
  237. }
  238. /* clause (c) */
  239. if( !IsConformantArray(formaltype->arr_elem) )
  240. return TstTypeEquiv(actualtype->arr_elem, formaltype->arr_elem);
  241. else
  242. return TstConform(formaltype->arr_elem, actualtype->arr_elem,
  243. new_par_section);
  244. }