typequiv.c 6.4 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314
  1. /*
  2. * (c) copyright 1987 by the Vrije Universiteit, Amsterdam, The Netherlands.
  3. * See the copyright notice in the ACK home directory, in the file "Copyright".
  4. *
  5. * Author: Ceriel J.H. Jacobs
  6. */
  7. /* T Y P E E Q U I V A L E N C E */
  8. /* $Id$ */
  9. /* Routines for testing type equivalence, type compatibility, and
  10. assignment compatibility
  11. */
  12. #include "debug.h"
  13. #include <em_arith.h>
  14. #include <em_label.h>
  15. #include <assert.h>
  16. #include "strict3rd.h"
  17. #include "type.h"
  18. #include "LLlex.h"
  19. #include "idf.h"
  20. #include "def.h"
  21. #include "node.h"
  22. #include "warning.h"
  23. #include "main.h"
  24. #include "Lpars.h"
  25. extern char *sprint();
  26. int
  27. TstTypeEquiv(tp1, tp2)
  28. t_type *tp1, *tp2;
  29. {
  30. /* test if two types are equivalent.
  31. */
  32. return tp1 == tp2
  33. ||
  34. tp1 == error_type
  35. ||
  36. tp2 == error_type;
  37. }
  38. int
  39. TstParEquiv(tp1, tp2)
  40. register t_type *tp1, *tp2;
  41. {
  42. /* test if two parameter types are equivalent. This routine
  43. is used to check if two different procedure declarations
  44. (one in the definition module, one in the implementation
  45. module) are equivalent. A complication comes from dynamic
  46. arrays.
  47. */
  48. return
  49. TstTypeEquiv(tp1, tp2)
  50. ||
  51. (
  52. IsConformantArray(tp1)
  53. &&
  54. IsConformantArray(tp2)
  55. &&
  56. TstTypeEquiv(tp1->arr_elem, tp2->arr_elem)
  57. );
  58. }
  59. int
  60. TstProcEquiv(tp1, tp2)
  61. t_type *tp1, *tp2;
  62. {
  63. /* Test if two procedure types are equivalent. This routine
  64. may also be used for the testing of assignment compatibility
  65. between procedure variables and procedures.
  66. */
  67. register t_param *p1, *p2;
  68. /* First check if the result types are equivalent
  69. */
  70. if (! TstTypeEquiv(ResultType(tp1), ResultType(tp2))) return 0;
  71. p1 = ParamList(tp1);
  72. p2 = ParamList(tp2);
  73. /* Now check the parameters
  74. */
  75. while (p1 && p2) {
  76. if (IsVarParam(p1) != IsVarParam(p2) ||
  77. !TstParEquiv(TypeOfParam(p1), TypeOfParam(p2))) return 0;
  78. p1 = p1->par_next;
  79. p2 = p2->par_next;
  80. }
  81. /* Here, at least one of the parameterlists is exhausted.
  82. Check that they are both.
  83. */
  84. return p1 == p2;
  85. }
  86. int
  87. TstCompat(tp1, tp2)
  88. register t_type *tp1, *tp2;
  89. {
  90. /* test if two types are compatible. See section 6.3 of the
  91. Modula-2 Report for a definition of "compatible".
  92. */
  93. if (TstTypeEquiv(tp1, tp2)) return 1;
  94. tp1 = BaseType(tp1);
  95. tp2 = BaseType(tp2);
  96. if (tp2->tp_fund != T_INTORCARD &&
  97. (tp1->tp_fund == T_INTORCARD || tp1 == address_type)) {
  98. t_type *tmp = tp2;
  99. tp2 = tp1;
  100. tp1 = tmp;
  101. }
  102. return tp1 == tp2
  103. ||
  104. ( tp2 == intorcard_type
  105. &&
  106. (tp1 == int_type || tp1 == card_type || tp1 == address_type)
  107. )
  108. ||
  109. ( tp2 == longintorcard_type
  110. &&
  111. (tp1 == longint_type || tp1 == longcard_type || tp1 == address_type)
  112. )
  113. ||
  114. ( tp2 == address_type
  115. &&
  116. ( tp1->tp_fund == T_CARDINAL || tp1->tp_fund == T_POINTER)
  117. )
  118. ;
  119. }
  120. int
  121. TstAssCompat(tp1, tp2)
  122. register t_type *tp1, *tp2;
  123. {
  124. /* Test if two types are assignment compatible.
  125. See Def 9.1.
  126. */
  127. if (TstCompat(tp1, tp2)) return 1;
  128. tp1 = BaseType(tp1);
  129. tp2 = BaseType(tp2);
  130. if (((tp1->tp_fund & T_INTORCARD) || tp1 == address_type) &&
  131. ((tp2->tp_fund & T_INTORCARD) || tp2 == address_type)) return 1;
  132. if ((tp1->tp_fund == T_REAL) &&
  133. (tp2->tp_fund == T_REAL)) return 1;
  134. if (tp1->tp_fund == T_PROCEDURE &&
  135. tp2->tp_fund == T_PROCEDURE) {
  136. return TstProcEquiv(tp1, tp2);
  137. }
  138. if (tp1->tp_fund == T_ARRAY) {
  139. /* check for string
  140. */
  141. if (IsConformantArray(tp1)) return 0;
  142. return
  143. BaseType(tp1->arr_elem) == char_type
  144. && tp2->tp_fund == T_STRING
  145. && (tp1->arr_high - tp1->arr_low + 1) >= tp2->tp_size
  146. ;
  147. }
  148. return 0;
  149. }
  150. char *
  151. incompat(tp1, tp2)
  152. register t_type *tp1, *tp2;
  153. {
  154. if (tp1->tp_fund == T_HIDDEN || tp2->tp_fund == T_HIDDEN) {
  155. return "properties of opaque type are hidden; illegal use";
  156. }
  157. return "type incompatibility";
  158. }
  159. int
  160. TstParCompat(parno, formaltype, VARflag, nd, edf)
  161. register t_type *formaltype;
  162. t_node **nd;
  163. t_def *edf;
  164. {
  165. /* Check type compatibility for a parameter in a procedure call.
  166. Assignment compatibility may do if the parameter is
  167. a value parameter.
  168. Otherwise, a conformant array may do, or an ARRAY OF (WORD|BYTE)
  169. may do too.
  170. Or: a WORD may do.
  171. */
  172. register t_type *actualtype = (*nd)->nd_type;
  173. char ebuf[256];
  174. if (edf) {
  175. sprint(ebuf, "\"%s\", parameter %d: %%s", edf->df_idf->id_text, parno);
  176. }
  177. else sprint(ebuf, "parameter %d: %%s", parno);
  178. if (
  179. TstTypeEquiv(formaltype, actualtype)
  180. ||
  181. ( !VARflag && ChkAssCompat(nd, formaltype, (char *) 0))
  182. ||
  183. ( formaltype == address_type
  184. && actualtype->tp_fund == T_POINTER
  185. )
  186. ||
  187. ( formaltype == word_type
  188. &&
  189. ( actualtype->tp_size == word_size
  190. ||
  191. ( !VARflag
  192. &&
  193. actualtype->tp_size <= word_size
  194. &&
  195. ! IsConformantArray(actualtype)
  196. )
  197. )
  198. )
  199. ||
  200. ( formaltype == byte_type
  201. && actualtype->tp_size == (arith) 1
  202. )
  203. ||
  204. ( IsConformantArray(formaltype)
  205. &&
  206. ( formaltype->arr_elem == word_type
  207. || formaltype->arr_elem == byte_type
  208. ||
  209. ( actualtype->tp_fund == T_ARRAY
  210. && TstTypeEquiv(formaltype->arr_elem,actualtype->arr_elem)
  211. )
  212. ||
  213. ( actualtype->tp_fund == T_STRING
  214. && TstTypeEquiv(formaltype->arr_elem, char_type)
  215. )
  216. )
  217. )
  218. )
  219. return 1;
  220. #ifndef STRICT_3RD_ED
  221. if (! options['3'] && VARflag && TstCompat(formaltype, actualtype)) {
  222. if (formaltype->tp_size == actualtype->tp_size) {
  223. node_warning(*nd,
  224. W_OLDFASHIONED,
  225. ebuf,
  226. "identical types required");
  227. return 1;
  228. }
  229. node_error(*nd, ebuf, "equal sized types required");
  230. return 0;
  231. }
  232. #endif
  233. node_error(*nd, ebuf, incompat(formaltype, actualtype));
  234. return 0;
  235. }
  236. CompatCheck(nd, tp, message, fc)
  237. register t_node **nd;
  238. t_type *tp;
  239. char *message;
  240. int (*fc)();
  241. {
  242. if (! (*fc)(tp, (*nd)->nd_type)) {
  243. if (message) {
  244. node_error(*nd, "%s in %s",
  245. incompat(tp, (*nd)->nd_type),
  246. message);
  247. }
  248. return 0;
  249. }
  250. MkCoercion(nd, tp);
  251. return 1;
  252. }
  253. ChkAssCompat(nd, tp, message)
  254. t_node **nd;
  255. t_type *tp;
  256. char *message;
  257. {
  258. /* Check assignment compatibility of node "nd" with type "tp".
  259. Give an error message when it fails
  260. */
  261. if ((*nd)->nd_symb == STRING) {
  262. TryToString((*nd), tp);
  263. }
  264. return CompatCheck(nd, tp, message, TstAssCompat);
  265. }
  266. ChkCompat(nd, tp, message)
  267. t_node **nd;
  268. t_type *tp;
  269. char *message;
  270. {
  271. /* Check compatibility of node "nd" with type "tp".
  272. Give an error message when it fails
  273. */
  274. return CompatCheck(nd, tp, message, TstCompat);
  275. }