?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
not needed
[prop.git] / prop-src / type.cc
blob06b8a694cf9399664e89f7d4c589ff2e91327528
1 ///////////////////////////////////////////////////////////////////////////////
2 // This file is generated automatically using Prop (version 2.3.6),
3 // last updated on Nov 2, 1999.
4 // The original source file is "type.pcc".
5 ///////////////////////////////////////////////////////////////////////////////
6
7 #define PROP_QUARK_USED
8 #include <propdefs.h>
9 ///////////////////////////////////////////////////////////////////////////////
10 // Quark literals
11 ///////////////////////////////////////////////////////////////////////////////
12 static const Quark _t_y_p_eco_c_c_Q5("void");
13 static const Quark _t_y_p_eco_c_c_Q2("int");
14 static const Quark _t_y_p_eco_c_c_Q4("bool");
15 static const Quark _t_y_p_eco_c_c_Q6("Quark");
16 static const Quark _t_y_p_eco_c_c_Q1("char");
17 static const Quark _t_y_p_eco_c_c_Q7("BigInt");
18 static const Quark _t_y_p_eco_c_c_Q3("double");
19 #line 1 "type.pcc"
20 /////////////////////////////////////////////////////////////////////////////
21 //
22 // This file implements the type analysis and type inference module
23 // in the Prop -> C++ translator.
24 //
25 /////////////////////////////////////////////////////////////////////////////
26
27 #include <AD/strings/quark.h>
28 #include "hashtab.h"
29 #include "ir.h"
30 #include "ast.h"
31 #include "collection.h"
32 #include "type.h"
33 #include "datatype.h"
34 #include "list.h"
35 #include "options.h"
36
37 /////////////////////////////////////////////////////////////////////////////
38 //
39 // Types for literals
40 //
41 /////////////////////////////////////////////////////////////////////////////
42 Ty string_ty = NOty,
43 character_ty = NOty,
44 integer_ty = NOty,
45 real_ty = NOty,
46 bool_ty = NOty,
47 void_ty = NOty,
48 quark_ty = NOty,
49 bigint_ty = NOty;
50
51 /////////////////////////////////////////////////////////////////////////////
52 //
53 // Initialize the types
54 //
55 /////////////////////////////////////////////////////////////////////////////
56 void initialize_types()
57 { character_ty = mkidty(
58 #line 38 "type.pcc"
59 #line 38 "type.pcc"
60 _t_y_p_eco_c_c_Q1
61 #line 38 "type.pcc"
62 #line 38 "type.pcc"
63 ,
64 #line 38 "type.pcc"
65 #line 38 "type.pcc"
66 nil_1_
67 #line 38 "type.pcc"
68 #line 38 "type.pcc"
69 );
70 string_ty = mkptrty(QUALty(QUALconst,character_ty));
71 integer_ty = mkidty(
72 #line 40 "type.pcc"
73 #line 40 "type.pcc"
74 _t_y_p_eco_c_c_Q2
75 #line 40 "type.pcc"
76 #line 40 "type.pcc"
77 ,
78 #line 40 "type.pcc"
79 #line 40 "type.pcc"
80 nil_1_
81 #line 40 "type.pcc"
82 #line 40 "type.pcc"
83 );
84 real_ty = mkidty(
85 #line 41 "type.pcc"
86 #line 41 "type.pcc"
87 _t_y_p_eco_c_c_Q3
88 #line 41 "type.pcc"
89 #line 41 "type.pcc"
90 ,
91 #line 41 "type.pcc"
92 #line 41 "type.pcc"
93 nil_1_
94 #line 41 "type.pcc"
95 #line 41 "type.pcc"
96 );
97 bool_ty = mkidty(
98 #line 42 "type.pcc"
99 #line 42 "type.pcc"
100 _t_y_p_eco_c_c_Q4
101 #line 42 "type.pcc"
102 #line 42 "type.pcc"
103 ,
104 #line 42 "type.pcc"
105 #line 42 "type.pcc"
106 nil_1_
107 #line 42 "type.pcc"
108 #line 42 "type.pcc"
109 );
110 void_ty = mkidty(
111 #line 43 "type.pcc"
112 #line 43 "type.pcc"
113 _t_y_p_eco_c_c_Q5
114 #line 43 "type.pcc"
115 #line 43 "type.pcc"
116 ,
117 #line 43 "type.pcc"
118 #line 43 "type.pcc"
119 nil_1_
120 #line 43 "type.pcc"
121 #line 43 "type.pcc"
122 );
123 quark_ty = mkidty(
124 #line 44 "type.pcc"
125 #line 44 "type.pcc"
126 _t_y_p_eco_c_c_Q6
127 #line 44 "type.pcc"
128 #line 44 "type.pcc"
129 ,
130 #line 44 "type.pcc"
131 #line 44 "type.pcc"
132 nil_1_
133 #line 44 "type.pcc"
134 #line 44 "type.pcc"
135 );
136 bigint_ty = mkidty(
137 #line 45 "type.pcc"
138 #line 45 "type.pcc"
139 _t_y_p_eco_c_c_Q7
140 #line 45 "type.pcc"
141 #line 45 "type.pcc"
142 ,
143 #line 45 "type.pcc"
144 #line 45 "type.pcc"
145 nil_1_
146 #line 45 "type.pcc"
147 #line 45 "type.pcc"
148 );
149 }
150
151 /////////////////////////////////////////////////////////////////////////////
152 //
153 // Make a type variable
154 //
155 /////////////////////////////////////////////////////////////////////////////
156 Ty mkvar() { return VARty(NOty); }
157
158 /////////////////////////////////////////////////////////////////////////////
159 //
160 // Constructors for some common types
161 //
162 /////////////////////////////////////////////////////////////////////////////
163 Ty mkptrty (Ty ty) { return TYCONty(POINTERtycon,
164 #line 60 "type.pcc"
165 #line 60 "type.pcc"
166 list_1_(ty)
167 #line 60 "type.pcc"
168 #line 60 "type.pcc"
169 ); }
170 Ty mkrefty (Ty ty) { return TYCONty(REFtycon,
171 #line 61 "type.pcc"
172 #line 61 "type.pcc"
173 list_1_(ty)
174 #line 61 "type.pcc"
175 #line 61 "type.pcc"
176 ); }
177 Ty mkfunty (Ty a, Ty b) { return TYCONty(FUNtycon,
178 #line 62 "type.pcc"
179 #line 62 "type.pcc"
180 list_1_(a,list_1_(b))
181 #line 62 "type.pcc"
182 #line 62 "type.pcc"
183 ); }
184 Ty mkarrayty (Ty a, Exp e) { return TYCONty(ARRAYtycon(e),
185 #line 63 "type.pcc"
186 #line 63 "type.pcc"
187 list_1_(a)
188 #line 63 "type.pcc"
189 #line 63 "type.pcc"
190 ); }
191 Ty mkidty (Id id, Tys args) { return TYCONty(IDtycon(id), args); }
192 Ty mkidvarty (Id id, TyVars args) { return TYCONty(IDtycon(id), tyvars_to_tys(args)); }
193 Ty mktuplety (Tys tys) { return TYCONty(TUPLEtycon, tys); }
194 Ty mkrecordty (Ids l, Tys t, Bool f) { return TYCONty(RECORDtycon(l,f), t); }
195 Ty mktypety () { return TYCONty(TYPEtycon,
196 #line 68 "type.pcc"
197 #line 68 "type.pcc"
198 nil_1_
199 #line 68 "type.pcc"
200 #line 68 "type.pcc"
201 ); }
202 Tys tyvars_to_tys (TyVars a)
203 {
204 #line 70 "type.pcc"
205 #line 72 "type.pcc"
206 {
207 if (a) {
208 #line 72 "type.pcc"
209 return
210 #line 72 "type.pcc"
211 #line 72 "type.pcc"
212 list_1_(mkidty(a->_1,nil_1_),tyvars_to_tys(a->_2))
213 #line 72 "type.pcc"
214 #line 72 "type.pcc"
215 ;
216 #line 72 "type.pcc"
217 } else {
218 #line 71 "type.pcc"
219 return
220 #line 71 "type.pcc"
221 #line 71 "type.pcc"
222 nil_1_
223 #line 71 "type.pcc"
224 #line 71 "type.pcc"
225 ;
226 #line 71 "type.pcc"
227 }
228 }
229 #line 73 "type.pcc"
230 #line 73 "type.pcc"
231
232 }
233
234 /////////////////////////////////////////////////////////////////////////////
235 //
236 // Return the representation tag of a constructor
237 //
238 /////////////////////////////////////////////////////////////////////////////
239 int tag_of(Cons cons)
240 {
241 #line 82 "type.pcc"
242 #line 85 "type.pcc"
243 {
244 if (cons) {
245 if (cons->alg_ty) {
246 switch (cons->alg_ty->tag__) {
247 case a_Ty::tag_TYCONty: {
248 if (boxed(((Ty_TYCONty *)cons->alg_ty)->_1)) {
249 switch (((Ty_TYCONty *)cons->alg_ty)->_1->tag__) {
250 case a_TyCon::tag_DATATYPEtycon: {
251 #line 84 "type.pcc"
252 return cons->tag + ((((TyCon_DATATYPEtycon *)((Ty_TYCONty *)cons->alg_ty)->_1)->qualifiers & QUALlexeme) ? 256 : 0);
253 #line 84 "type.pcc"
254 } break;
255 default: {
256 L1:;
257 #line 85 "type.pcc"
258 return 0;
259 #line 85 "type.pcc"
260 } break;
261 }
262 } else { goto L1; }
263 } break;
264 default: { goto L1; } break;
265 }
266 } else { goto L1; }
267 } else { goto L1; }
268 }
269 #line 86 "type.pcc"
270 #line 86 "type.pcc"
271
272 }
273
274 /////////////////////////////////////////////////////////////////////////////
275 // Convert type variables to a type list
276 /////////////////////////////////////////////////////////////////////////////
277 Tys tyvars_to_type_list(int i, TyVars tyvars)
278 {
279 #line 93 "type.pcc"
280 #line 95 "type.pcc"
281 {
282 if (tyvars) {
283 #line 95 "type.pcc"
284 return
285 #line 95 "type.pcc"
286 #line 95 "type.pcc"
287 list_1_(INDty(tyvars->_1,i),tyvars_to_type_list((i + 1),tyvars->_2))
288 #line 95 "type.pcc"
289 #line 95 "type.pcc"
290 ;
291 #line 95 "type.pcc"
292 } else {
293 #line 94 "type.pcc"
294 return
295 #line 94 "type.pcc"
296 #line 94 "type.pcc"
297 nil_1_
298 #line 94 "type.pcc"
299 #line 94 "type.pcc"
300 ;
301 #line 94 "type.pcc"
302 }
303 }
304 #line 96 "type.pcc"
305 #line 96 "type.pcc"
306
307 }
308
309 /////////////////////////////////////////////////////////////////////////////
310 //
311 // Make a universally quantified type
312 //
313 /////////////////////////////////////////////////////////////////////////////
314 Ty mkpolyty(Ty ty, TyVars tyvars)
315 { int arity = length(tyvars);
316 if (arity == 0) return ty;
317 Id * bound_vars = (Id *)mem_pool[arity * sizeof(Id)];
318 int i = 0;
319 for_each (TyVar, tv, tyvars)
320 bound_vars[i++] = tv;
321 return POLYty(deref(ty),arity,bound_vars);
322 /*
323 match (deref(ty))
324 { TYCONty(tycon,_):
325 { return POLYty
326 (TYCONty(tycon,tyvars_to_type_list(0,tyvars)), arity, bound_vars);
327 }
328 | _: { bug("mkpolyty()"); }
329 }
330 */
331 }
332
333 /////////////////////////////////////////////////////////////////////////////
334 //
335 // Dereference a type expression
336 //
337 /////////////////////////////////////////////////////////////////////////////
338 Ty deref_all(Ty ty)
339 {
340 #line 129 "type.pcc"
341 #line 141 "type.pcc"
342 {
343 for (;;) {
344 if (ty) {
345 switch (ty->tag__) {
346 case a_Ty::tag_VARty: {
347 if (((Ty_VARty *)ty)->VARty) {
348 #line 130 "type.pcc"
349 ty = ((Ty_VARty *)ty)->VARty;
350 #line 130 "type.pcc"
351 } else {
352 L3:;
353 #line 141 "type.pcc"
354 return ty;
355 #line 141 "type.pcc"
356 }
357 } break;
358 case a_Ty::tag_QUALty: {
359 #line 131 "type.pcc"
360 ty = ((Ty_QUALty *)ty)->_2;
361 #line 131 "type.pcc"
362 } break;
363 case a_Ty::tag_TYCONty: {
364 if (boxed(((Ty_TYCONty *)ty)->_1)) {
365 switch (((Ty_TYCONty *)ty)->_1->tag__) {
366 case a_TyCon::tag_IDtycon: {
367 if (((Ty_TYCONty *)ty)->_2) {
368 #line 136 "type.pcc"
369
370 #line 136 "type.pcc"
371 #line 138 "type.pcc"
372 {
373 Ty _V1 = lookup_ty(((TyCon_IDtycon *)((Ty_TYCONty *)ty)->_1)->IDtycon);
374 if (_V1) {
375 switch (_V1->tag__) {
376 case a_Ty::tag_TYCONty: {
377 #line 137 "type.pcc"
378 return TYCONty(((Ty_TYCONty *)_V1)->_1,((Ty_TYCONty *)ty)->_2);
379 #line 137 "type.pcc"
380 } break;
381 default: {
382 L4:;
383 #line 138 "type.pcc"
384 return ty;
385 #line 138 "type.pcc"
386 } break;
387 }
388 } else { goto L4; }
389 }
390 #line 139 "type.pcc"
391 #line 139 "type.pcc"
392
393
394 #line 140 "type.pcc"
395 } else {
396 #line 134 "type.pcc"
397 Ty t = lookup_ty(((TyCon_IDtycon *)((Ty_TYCONty *)ty)->_1)->IDtycon); if (t != NOty) ty = t; else return ty;
398 #line 134 "type.pcc"
399 }
400 } break;
401 default: { goto L3; } break;
402 }
403 } else { goto L3; }
404 } break;
405 case a_Ty::tag_DEFVALty: {
406 #line 132 "type.pcc"
407 ty = ((Ty_DEFVALty *)ty)->_1;
408 #line 132 "type.pcc"
409 } break;
410 default: { goto L3; } break;
411 }
412 } else { goto L3; }
413 }
414 }
415 #line 142 "type.pcc"
416 #line 142 "type.pcc"
417
418 }
419
420 /////////////////////////////////////////////////////////////////////////////
421 //
422 // Dereference a type expression.
423 //
424 /////////////////////////////////////////////////////////////////////////////
425 Ty deref(Ty ty)
426 {
427 #line 151 "type.pcc"
428 #line 151 "type.pcc"
429 {
430 for (;;) {
431 if (ty) {
432 switch (ty->tag__) {
433 case a_Ty::tag_VARty: {
434 if (((Ty_VARty *)ty)->VARty) {
435 #line 151 "type.pcc"
436 ty = ((Ty_VARty *)ty)->VARty;
437 #line 151 "type.pcc"
438 } else { goto L5; }
439 } break;
440 default: { goto L5; } break;
441 }
442 } else { goto L5; }
443 }
444 L5:;
445 }
446 #line 151 "type.pcc"
447 #line 151 "type.pcc"
448
449 return ty;
450 }
451
452 /////////////////////////////////////////////////////////////////////////////
453 //
454 // Get the default value of a type (if any)
455 //
456 /////////////////////////////////////////////////////////////////////////////
457 Exp default_val(Ty ty)
458 {
459 #line 161 "type.pcc"
460 #line 163 "type.pcc"
461 {
462 Ty _V2 = deref(ty);
463 if (_V2) {
464 switch (_V2->tag__) {
465 case a_Ty::tag_DEFVALty: {
466 #line 162 "type.pcc"
467 return ((Ty_DEFVALty *)_V2)->_2;
468 #line 162 "type.pcc"
469 } break;
470 default: {
471 L6:;
472 #line 163 "type.pcc"
473 return NOexp;
474 #line 163 "type.pcc"
475 } break;
476 }
477 } else { goto L6; }
478 }
479 #line 164 "type.pcc"
480 #line 164 "type.pcc"
481
482 }
483
484 /////////////////////////////////////////////////////////////////////////////
485 //
486 // Test for qualifiers in a type
487 //
488 /////////////////////////////////////////////////////////////////////////////
489 Bool has_qual(TyQual q, Ty ty)
490 {
491 #line 173 "type.pcc"
492 #line 178 "type.pcc"
493 {
494 for (;;) {
495 if (ty) {
496 switch (ty->tag__) {
497 case a_Ty::tag_VARty: {
498 #line 174 "type.pcc"
499 ty = ((Ty_VARty *)ty)->VARty;
500 #line 174 "type.pcc"
501 } break;
502 case a_Ty::tag_QUALty: {
503 #line 178 "type.pcc"
504 if (q & ((Ty_QUALty *)ty)->_1) return true; ty = ((Ty_QUALty *)ty)->_2;
505 #line 178 "type.pcc"
506 } break;
507 case a_Ty::tag_TYCONty: {
508 if (boxed(((Ty_TYCONty *)ty)->_1)) {
509 switch (((Ty_TYCONty *)ty)->_1->tag__) {
510 case a_TyCon::tag_DATATYPEtycon: {
511 #line 177 "type.pcc"
512 return ((TyCon_DATATYPEtycon *)((Ty_TYCONty *)ty)->_1)->qualifiers & q;
513 #line 177 "type.pcc"
514 } break;
515 default: { goto L7; } break;
516 }
517 } else { goto L7; }
518 } break;
519 case a_Ty::tag_DEFVALty: {
520 #line 176 "type.pcc"
521 ty = ((Ty_DEFVALty *)ty)->_1;
522 #line 176 "type.pcc"
523 } break;
524 case a_Ty::tag_NESTEDty: {
525 #line 175 "type.pcc"
526 ty = ((Ty_NESTEDty *)ty)->_2;
527 #line 175 "type.pcc"
528 } break;
529 default: { goto L7; } break;
530 }
531 } else { goto L7; }
532 }
533 L7:;
534 }
535 #line 179 "type.pcc"
536 #line 179 "type.pcc"
537
538 return false;
539 }
540
541 /////////////////////////////////////////////////////////////////////////////
542 //
543 // Test if a type is grounded (i.e. contains no type variables.)
544 //
545 /////////////////////////////////////////////////////////////////////////////
546 Bool is_ground(Ty ty)
547 {
548 #line 189 "type.pcc"
549 #line 195 "type.pcc"
550 {
551 for (;;) {
552 if (ty) {
553 switch (ty->tag__) {
554 case a_Ty::tag_VARty: {
555 #line 190 "type.pcc"
556 ty = ((Ty_VARty *)ty)->VARty;
557 #line 190 "type.pcc"
558 } break;
559 case a_Ty::tag_QUALty: {
560 #line 191 "type.pcc"
561 ty = ((Ty_QUALty *)ty)->_2;
562 #line 191 "type.pcc"
563 } break;
564 case a_Ty::tag_TYCONty: {
565 #line 194 "type.pcc"
566 return is_ground(((Ty_TYCONty *)ty)->_2);
567 #line 194 "type.pcc"
568 } break;
569 case a_Ty::tag_DEFVALty: {
570 #line 192 "type.pcc"
571 ty = ((Ty_DEFVALty *)ty)->_1;
572 #line 192 "type.pcc"
573 } break;
574 case a_Ty::tag_NESTEDty: {
575 #line 193 "type.pcc"
576 if (! is_ground(((Ty_NESTEDty *)ty)->_1)) return false; ty = ((Ty_NESTEDty *)ty)->_2;
577 #line 193 "type.pcc"
578 } break;
579 default: {
580 L9:;
581 #line 195 "type.pcc"
582 return false;
583 #line 195 "type.pcc"
584 } break;
585 }
586 } else { goto L9; }
587 }
588 }
589 #line 196 "type.pcc"
590 #line 196 "type.pcc"
591
592 }
593
594 /////////////////////////////////////////////////////////////////////////////
595 //
596 // Test if a type list is grounded
597 //
598 /////////////////////////////////////////////////////////////////////////////
599 Bool is_ground(Tys tys)
600 { for_each (Ty, t, tys) if (! is_ground(t)) return false;
601 return true;
602 }
603
604 /////////////////////////////////////////////////////////////////////////////
605 //
606 // Test if a type is an array
607 //
608 /////////////////////////////////////////////////////////////////////////////
609 Bool is_array_ty(Ty ty)
610 {
611 #line 215 "type.pcc"
612 #line 218 "type.pcc"
613 {
614 Ty _V3 = deref_all(ty);
615 if (_V3) {
616 switch (_V3->tag__) {
617 case a_Ty::tag_TYCONty: {
618 if (boxed(((Ty_TYCONty *)_V3)->_1)) {
619 switch (((Ty_TYCONty *)_V3)->_1->tag__) {
620 case a_TyCon::tag_ARRAYtycon: {
621 if (((TyCon_ARRAYtycon *)((Ty_TYCONty *)_V3)->_1)->ARRAYtycon) {
622 if (((Ty_TYCONty *)_V3)->_2) {
623 L10:;
624 if (((Ty_TYCONty *)_V3)->_2->_2) {
625 L11:;
626 #line 218 "type.pcc"
627 return false;
628 #line 218 "type.pcc"
629 } else {
630 L12:;
631 #line 216 "type.pcc"
632 return true;
633 #line 216 "type.pcc"
634 }
635 } else { goto L11; }
636 } else { goto L11; }
637 } break;
638 default: { goto L11; } break;
639 }
640 } else { goto L11; }
641 } break;
642 case a_Ty::tag_NESTEDty: {
643 #line 217 "type.pcc"
644 return is_array_ty(((Ty_NESTEDty *)_V3)->_2);
645 #line 217 "type.pcc"
646 } break;
647 default: { goto L11; } break;
648 }
649 } else { goto L11; }
650 }
651 #line 219 "type.pcc"
652 #line 219 "type.pcc"
653
654 }
655
656 /////////////////////////////////////////////////////////////////////////////
657 //
658 // Test if a type is a polymorphic datatype
659 //
660 /////////////////////////////////////////////////////////////////////////////
661 Bool is_poly_datatype(Ty ty)
662 {
663 #line 228 "type.pcc"
664 #line 230 "type.pcc"
665 {
666 Ty _V4 = deref_all(ty);
667 if (_V4) {
668 switch (_V4->tag__) {
669 case a_Ty::tag_TYCONty: {
670 if (boxed(((Ty_TYCONty *)_V4)->_1)) {
671 switch (((Ty_TYCONty *)_V4)->_1->tag__) {
672 case a_TyCon::tag_DATATYPEtycon: {
673 #line 229 "type.pcc"
674 return ((TyCon_DATATYPEtycon *)((Ty_TYCONty *)_V4)->_1)->tyvars !=
675 #line 229 "type.pcc"
676 #line 229 "type.pcc"
677 nil_1_
678 #line 229 "type.pcc"
679 #line 229 "type.pcc"
680 ;
681 #line 229 "type.pcc"
682 } break;
683 default: {
684 L13:;
685 #line 230 "type.pcc"
686 return false;
687 #line 230 "type.pcc"
688 } break;
689 }
690 } else { goto L13; }
691 } break;
692 default: { goto L13; } break;
693 }
694 } else { goto L13; }
695 }
696 #line 231 "type.pcc"
697 #line 231 "type.pcc"
698
699 }
700
701 /////////////////////////////////////////////////////////////////////////////
702 //
703 // Test if a type is a datatype.
704 //
705 /////////////////////////////////////////////////////////////////////////////
706 Bool is_datatype(Ty ty)
707 {
708 #line 240 "type.pcc"
709 #line 242 "type.pcc"
710 {
711 Ty _V5 = deref_all(ty);
712 if (_V5) {
713 switch (_V5->tag__) {
714 case a_Ty::tag_TYCONty: {
715 if (boxed(((Ty_TYCONty *)_V5)->_1)) {
716 switch (((Ty_TYCONty *)_V5)->_1->tag__) {
717 case a_TyCon::tag_DATATYPEtycon: {
718 #line 241 "type.pcc"
719 return true;
720 #line 241 "type.pcc"
721 } break;
722 default: {
723 L14:;
724 #line 242 "type.pcc"
725 return false;
726 #line 242 "type.pcc"
727 } break;
728 }
729 } else { goto L14; }
730 } break;
731 default: { goto L14; } break;
732 }
733 } else { goto L14; }
734 }
735 #line 243 "type.pcc"
736 #line 243 "type.pcc"
737
738 }
739
740 /////////////////////////////////////////////////////////////////////////////
741 //
742 // Add a new class to an inheritance list
743 //
744 /////////////////////////////////////////////////////////////////////////////
745 Inherits add_inherit(Id id, TyVars p, Inherits i, Scope s, TyQual t)
746 { Inherit inh =
747 #line 252 "type.pcc"
748 #line 252 "type.pcc"
749 INHERIT(mkidty(id,tyvars_to_tys(p)), s, t)
750 #line 254 "type.pcc"
751 #line 254 "type.pcc"
752 ;
753 return
754 #line 255 "type.pcc"
755 #line 255 "type.pcc"
756 list_1_(inh,i)
757 #line 255 "type.pcc"
758 #line 255 "type.pcc"
759 ;
760 }
761
762
763 /////////////////////////////////////////////////////////////////////////////
764 //
765 // Test if a type is garbage collectable.
766 //
767 /////////////////////////////////////////////////////////////////////////////
768 Bool is_gc_ty(Ty ty)
769 {
770 #line 265 "type.pcc"
771 #line 279 "type.pcc"
772 {
773 for (;;) {
774 if (ty) {
775 switch (ty->tag__) {
776 case a_Ty::tag_VARty: {
777 #line 272 "type.pcc"
778 ty = ((Ty_VARty *)ty)->VARty;
779 #line 272 "type.pcc"
780 } break;
781 case a_Ty::tag_QUALty: {
782 #line 273 "type.pcc"
783 if (((Ty_QUALty *)ty)->_1 & QUALcollectable) return true; ty = ((Ty_QUALty *)ty)->_2;
784 #line 273 "type.pcc"
785 } break;
786 case a_Ty::tag_TYCONty: {
787 if (boxed(((Ty_TYCONty *)ty)->_1)) {
788 switch (((Ty_TYCONty *)ty)->_1->tag__) {
789 case a_TyCon::tag_IDtycon: {
790 #line 275 "type.pcc"
791 Ty t = deref_all(ty);
792 if (t == ty) return false;
793 ty = t;
794
795 #line 278 "type.pcc"
796 } break;
797 case a_TyCon::tag_DATATYPEtycon: {
798 #line 267 "type.pcc"
799 return (((TyCon_DATATYPEtycon *)((Ty_TYCONty *)ty)->_1)->qualifiers & QUALcollectable) && (((TyCon_DATATYPEtycon *)((Ty_TYCONty *)ty)->_1)->arg > 0);
800 #line 267 "type.pcc"
801 } break;
802 default: {
803 L16:;
804 #line 279 "type.pcc"
805 return false;
806 #line 279 "type.pcc"
807 } break;
808 }
809 } else {
810 switch ((int)((Ty_TYCONty *)ty)->_1) {
811 case ((int)POINTERtycon): {
812 if (((Ty_TYCONty *)ty)->_2) {
813 if (((Ty_TYCONty *)ty)->_2->_2) { goto L16; } else {
814 #line 269 "type.pcc"
815 ty = ((Ty_TYCONty *)ty)->_2->_1;
816 #line 269 "type.pcc"
817 }
818 } else { goto L16; }
819 } break;
820 case ((int)REFtycon): {
821 if (((Ty_TYCONty *)ty)->_2) {
822 if (((Ty_TYCONty *)ty)->_2->_2) { goto L16; } else {
823 #line 268 "type.pcc"
824 ty = ((Ty_TYCONty *)ty)->_2->_1;
825 #line 268 "type.pcc"
826 }
827 } else { goto L16; }
828 } break;
829 default: { goto L16; } break;
830 }
831 }
832 } break;
833 case a_Ty::tag_DEFVALty: {
834 #line 270 "type.pcc"
835 ty = ((Ty_DEFVALty *)ty)->_1;
836 #line 270 "type.pcc"
837 } break;
838 case a_Ty::tag_NESTEDty: {
839 #line 271 "type.pcc"
840 ty = ((Ty_NESTEDty *)ty)->_2;
841 #line 271 "type.pcc"
842 } break;
843 default: { goto L16; } break;
844 }
845 } else { goto L16; }
846 }
847 }
848 #line 280 "type.pcc"
849 #line 280 "type.pcc"
850
851 }
852
853 /////////////////////////////////////////////////////////////////////////////
854 //
855 // Test if type is a pointer.
856 //
857 /////////////////////////////////////////////////////////////////////////////
858 Bool is_pointer_ty(Ty ty)
859 {
860 #line 289 "type.pcc"
861 #line 291 "type.pcc"
862 {
863 Ty _V6 = deref_all(ty);
864 if (_V6) {
865 switch (_V6->tag__) {
866 case a_Ty::tag_TYCONty: {
867 if (boxed(((Ty_TYCONty *)_V6)->_1)) {
868 switch (((Ty_TYCONty *)_V6)->_1->tag__) {
869 case a_TyCon::tag_DATATYPEtycon: {
870 L17:;
871 #line 290 "type.pcc"
872 return true;
873 #line 290 "type.pcc"
874 } break;
875 default: {
876 L18:;
877 #line 291 "type.pcc"
878 return false;
879 #line 291 "type.pcc"
880 } break;
881 }
882 } else {
883 switch ((int)((Ty_TYCONty *)_V6)->_1) {
884 case ((int)POINTERtycon): { goto L17; } break;
885 default: { goto L18; } break;
886 }
887 }
888 } break;
889 default: { goto L18; } break;
890 }
891 } else { goto L18; }
892 }
893 #line 292 "type.pcc"
894 #line 292 "type.pcc"
895
896 }
897
898 /////////////////////////////////////////////////////////////////////////////
899 //
900 // Test if type is embeddable into 1 word
901 //
902 /////////////////////////////////////////////////////////////////////////////
903 Bool is_embeddable_ty(Ty ty)
904 {
905 #line 301 "type.pcc"
906 #line 309 "type.pcc"
907 {
908 Ty _V7 = deref_all(ty);
909 if (_V7) {
910 switch (_V7->tag__) {
911 case a_Ty::tag_TYCONty: {
912 if (
913 #line 306 "type.pcc"
914 ((ty_equal(_V7,integer_ty) || ty_equal(_V7,character_ty)) || ty_equal(_V7,bool_ty))
915 #line 308 "type.pcc"
916 ) {
917
918 if (boxed(((Ty_TYCONty *)_V7)->_1)) {
919 switch (((Ty_TYCONty *)_V7)->_1->tag__) {
920 case a_TyCon::tag_DATATYPEtycon: {
921 if (
922 #line 304 "type.pcc"
923 ((((TyCon_DATATYPEtycon *)((Ty_TYCONty *)_V7)->_1)->opt & OPTtaggedpointer) == 0)
924 #line 304 "type.pcc"
925 ) {
926
927 L19:;
928 switch (((TyCon_DATATYPEtycon *)((Ty_TYCONty *)_V7)->_1)->arg) {
929 case 0: {
930 L20:;
931 #line 302 "type.pcc"
932 return true;
933 #line 302 "type.pcc"
934 } break;
935 default: {
936 L21:;
937 #line 304 "type.pcc"
938 return true;
939 #line 304 "type.pcc"
940 }
941 }
942 } else {
943
944 switch (((TyCon_DATATYPEtycon *)((Ty_TYCONty *)_V7)->_1)->arg) {
945 case 0: { goto L20; } break;
946 default: {
947 L22:;
948 #line 308 "type.pcc"
949 return true;
950 #line 308 "type.pcc"
951 }
952 }
953 }
954 } break;
955 default: { goto L22; } break;
956 }
957 } else {
958 switch ((int)((Ty_TYCONty *)_V7)->_1) {
959 case ((int)POINTERtycon): {
960 if (((Ty_TYCONty *)_V7)->_2) {
961 if (((Ty_TYCONty *)_V7)->_2->_2) { goto L22; } else {
962 if (
963 #line 305 "type.pcc"
964 (((Ty_TYCONty *)_V7)->_2->_1 != character_ty)
965 #line 305 "type.pcc"
966 ) {
967
968 L23:;
969 #line 305 "type.pcc"
970 return true;
971 #line 305 "type.pcc"
972 } else {
973 goto L22; }
974 }
975 } else { goto L22; }
976 } break;
977 default: { goto L22; } break;
978 }
979 }
980 } else {
981
982 if (boxed(((Ty_TYCONty *)_V7)->_1)) {
983 switch (((Ty_TYCONty *)_V7)->_1->tag__) {
984 case a_TyCon::tag_DATATYPEtycon: {
985 if (
986 #line 304 "type.pcc"
987 ((((TyCon_DATATYPEtycon *)((Ty_TYCONty *)_V7)->_1)->opt & OPTtaggedpointer) == 0)
988 #line 304 "type.pcc"
989 ) {
990 goto L19; } else {
991
992 switch (((TyCon_DATATYPEtycon *)((Ty_TYCONty *)_V7)->_1)->arg) {
993 case 0: { goto L20; } break;
994 default: {
995 L24:;
996 #line 309 "type.pcc"
997 return false;
998 #line 309 "type.pcc"
999 }
1000 }
1001 }
1002 } break;
1003 default: { goto L24; } break;
1004 }
1005 } else {
1006 switch ((int)((Ty_TYCONty *)_V7)->_1) {
1007 case ((int)POINTERtycon): {
1008 if (((Ty_TYCONty *)_V7)->_2) {
1009 if (((Ty_TYCONty *)_V7)->_2->_2) { goto L24; } else {
1010 if (
1011 #line 305 "type.pcc"
1012 (((Ty_TYCONty *)_V7)->_2->_1 != character_ty)
1013 #line 305 "type.pcc"
1014 ) {
1015 goto L23; } else {
1016 goto L24; }
1017 }
1018 } else { goto L24; }
1019 } break;
1020 default: { goto L24; } break;
1021 }
1022 }
1023 }
1024 } break;
1025 default: {
1026 L25:;
1027 if (
1028 #line 306 "type.pcc"
1029 ((ty_equal(_V7,integer_ty) || ty_equal(_V7,character_ty)) || ty_equal(_V7,bool_ty))
1030 #line 308 "type.pcc"
1031 ) {
1032 goto L22; } else {
1033 goto L24; }
1034 } break;
1035 }
1036 } else { goto L25; }
1037 }
1038 #line 310 "type.pcc"
1039 #line 310 "type.pcc"
1040
1041 }
1042
1043 /////////////////////////////////////////////////////////////////////////////
1044 //
1045 // Test if constructor is an array-style constructor
1046 //
1047 /////////////////////////////////////////////////////////////////////////////
1048 Bool is_array_constructor(Id id) { return id[1] == '|'; }
1049 Bool is_list_constructor(Id id) { return id[0] == '#' &&
1050 (id[1] == '[' ||
1051 id[1] == '(' ||
1052 id[1] == '{'); }
1053 Bool is_list_constructor(Cons cons)
1054 { return cons != NOcons && is_list_constructor(cons->name); }
1055
1056 /////////////////////////////////////////////////////////////////////////////
1057 //
1058 // Returns the number of boxed variants.
1059 //
1060 /////////////////////////////////////////////////////////////////////////////
1061 int boxed_variants(Ty ty)
1062 {
1063 #line 332 "type.pcc"
1064 #line 334 "type.pcc"
1065 {
1066 Ty _V8 = deref_all(ty);
1067 if (_V8) {
1068 switch (_V8->tag__) {
1069 case a_Ty::tag_TYCONty: {
1070 if (boxed(((Ty_TYCONty *)_V8)->_1)) {
1071 switch (((Ty_TYCONty *)_V8)->_1->tag__) {
1072 case a_TyCon::tag_DATATYPEtycon: {
1073 #line 333 "type.pcc"
1074 return ((TyCon_DATATYPEtycon *)((Ty_TYCONty *)_V8)->_1)->arg;
1075 #line 333 "type.pcc"
1076 } break;
1077 default: {
1078 L26:;
1079 #line 334 "type.pcc"
1080 return 0;
1081 #line 334 "type.pcc"
1082 } break;
1083 }
1084 } else { goto L26; }
1085 } break;
1086 default: { goto L26; } break;
1087 }
1088 } else { goto L26; }
1089 }
1090 #line 335 "type.pcc"
1091 #line 335 "type.pcc"
1092
1093 }
1094
1095 int unboxed_variants(Ty ty)
1096 {
1097 #line 339 "type.pcc"
1098 #line 341 "type.pcc"
1099 {
1100 Ty _V9 = deref_all(ty);
1101 if (_V9) {
1102 switch (_V9->tag__) {
1103 case a_Ty::tag_TYCONty: {
1104 if (boxed(((Ty_TYCONty *)_V9)->_1)) {
1105 switch (((Ty_TYCONty *)_V9)->_1->tag__) {
1106 case a_TyCon::tag_DATATYPEtycon: {
1107 #line 340 "type.pcc"
1108 return ((TyCon_DATATYPEtycon *)((Ty_TYCONty *)_V9)->_1)->unit;
1109 #line 340 "type.pcc"
1110 } break;
1111 default: {
1112 L27:;
1113 #line 341 "type.pcc"
1114 return 0;
1115 #line 341 "type.pcc"
1116 } break;
1117 }
1118 } else { goto L27; }
1119 } break;
1120 default: { goto L27; } break;
1121 }
1122 } else { goto L27; }
1123 }
1124 #line 342 "type.pcc"
1125 #line 342 "type.pcc"
1126
1127 }
1128
1129 /////////////////////////////////////////////////////////////////////////////
1130 //
1131 // Returns the arity of a type
1132 //
1133 /////////////////////////////////////////////////////////////////////////////
1134 int arity_of(Ty ty)
1135 {
1136 #line 351 "type.pcc"
1137 #line 355 "type.pcc"
1138 {
1139 Ty _V10 = deref_all(ty);
1140 if (_V10) {
1141 switch (_V10->tag__) {
1142 case a_Ty::tag_TYCONty: {
1143 if (boxed(((Ty_TYCONty *)_V10)->_1)) {
1144 switch (((Ty_TYCONty *)_V10)->_1->tag__) {
1145 case a_TyCon::tag_RECORDtycon: {
1146 L28:;
1147 #line 353 "type.pcc"
1148 return length(((Ty_TYCONty *)_V10)->_2);
1149 #line 353 "type.pcc"
1150 } break;
1151 default: {
1152 L29:;
1153 #line 355 "type.pcc"
1154 return 1;
1155 #line 355 "type.pcc"
1156 } break;
1157 }
1158 } else {
1159 switch ((int)((Ty_TYCONty *)_V10)->_1) {
1160 case ((int)TUPLEtycon): { goto L28; } break;
1161 default: { goto L29; } break;
1162 }
1163 }
1164 } break;
1165 case a_Ty::tag_NESTEDty: {
1166 #line 354 "type.pcc"
1167 return arity_of(((Ty_NESTEDty *)_V10)->_2);
1168 #line 354 "type.pcc"
1169 } break;
1170 default: { goto L29; } break;
1171 }
1172 } else {
1173 #line 352 "type.pcc"
1174 return 0;
1175 #line 352 "type.pcc"
1176 }
1177 }
1178 #line 356 "type.pcc"
1179 #line 356 "type.pcc"
1180
1181 }
1182
1183 /////////////////////////////////////////////////////////////////////////////
1184 //
1185 // Instantiate a polymorphic type scheme
1186 //
1187 /////////////////////////////////////////////////////////////////////////////
1188 Ty inst (Ty ty, int n, Id bound_vars[], Ty subst[])
1189 {
1190 #line 365 "type.pcc"
1191 #line 376 "type.pcc"
1192 {
1193 Ty _V11 = deref(ty);
1194 if (_V11) {
1195 switch (_V11->tag__) {
1196 case a_Ty::tag_VARty: {
1197 L30:;
1198 #line 366 "type.pcc"
1199 return ty;
1200 #line 366 "type.pcc"
1201 } break;
1202 case a_Ty::tag_INDty: {
1203 #line 368 "type.pcc"
1204 return subst[((Ty_INDty *)_V11)->_2] != NOty ? subst[((Ty_INDty *)_V11)->_2] : (subst[((Ty_INDty *)_V11)->_2] = mkvar());
1205 #line 368 "type.pcc"
1206 } break;
1207 case a_Ty::tag_QUALty: {
1208 #line 369 "type.pcc"
1209 return QUALty(((Ty_QUALty *)_V11)->_1,inst(((Ty_QUALty *)_V11)->_2,n,bound_vars,subst));
1210 #line 369 "type.pcc"
1211 } break;
1212 case a_Ty::tag_TYCONty: {
1213 #line 375 "type.pcc"
1214 return TYCONty(((Ty_TYCONty *)_V11)->_1, inst(((Ty_TYCONty *)_V11)->_2,n,bound_vars,subst));
1215 #line 375 "type.pcc"
1216 } break;
1217 case a_Ty::tag_POLYty: {
1218 #line 376 "type.pcc"
1219 bug("inst()"); return NOty;
1220 #line 376 "type.pcc"
1221 } break;
1222 case a_Ty::tag_DEFVALty: {
1223 #line 370 "type.pcc"
1224 return DEFVALty(inst(((Ty_DEFVALty *)_V11)->_1,n,bound_vars,subst),((Ty_DEFVALty *)_V11)->_2);
1225 #line 370 "type.pcc"
1226 } break;
1227 default: {
1228 #line 371 "type.pcc"
1229 return NESTEDty(inst(((Ty_NESTEDty *)_V11)->_1,n,bound_vars,subst),
1230 inst(((Ty_NESTEDty *)_V11)->_2,n,bound_vars,subst));
1231
1232 #line 373 "type.pcc"
1233 } break;
1234 }
1235 } else { goto L30; }
1236 }
1237 #line 377 "type.pcc"
1238 #line 377 "type.pcc"
1239
1240 }
1241
1242 /////////////////////////////////////////////////////////////////////////////
1243 //
1244 // Instantiate a type list
1245 //
1246 /////////////////////////////////////////////////////////////////////////////
1247 Tys inst (Tys tys, int n, Id bound_vars[], Ty subst[])
1248 {
1249 #line 386 "type.pcc"
1250 #line 390 "type.pcc"
1251 {
1252 if (tys) {
1253 #line 388 "type.pcc"
1254 return
1255 #line 388 "type.pcc"
1256 #line 388 "type.pcc"
1257 list_1_(inst(tys->_1,n,bound_vars,subst),inst(tys->_2,n,bound_vars,subst))
1258 #line 389 "type.pcc"
1259 #line 389 "type.pcc"
1260 ;
1261
1262 #line 390 "type.pcc"
1263 } else {
1264 #line 387 "type.pcc"
1265 return
1266 #line 387 "type.pcc"
1267 #line 387 "type.pcc"
1268 nil_1_
1269 #line 387 "type.pcc"
1270 #line 387 "type.pcc"
1271 ;
1272 #line 387 "type.pcc"
1273 }
1274 }
1275 #line 391 "type.pcc"
1276 #line 391 "type.pcc"
1277
1278 }
1279
1280 /////////////////////////////////////////////////////////////////////////////
1281 //
1282 // Instantiate a polymorphic type scheme
1283 //
1284 /////////////////////////////////////////////////////////////////////////////
1285 Ty inst(Ty polyty)
1286 {
1287 #line 400 "type.pcc"
1288 #line 406 "type.pcc"
1289 {
1290 if (polyty) {
1291 switch (polyty->tag__) {
1292 case a_Ty::tag_POLYty: {
1293 #line 402 "type.pcc"
1294 Ty subst[256];
1295 for (int i = ((Ty_POLYty *)polyty)->_2 - 1; i >= 0; i--) subst[i] = NOty;
1296 return inst(((Ty_POLYty *)polyty)->_1, ((Ty_POLYty *)polyty)->_2, ((Ty_POLYty *)polyty)->_3, subst);
1297
1298 #line 405 "type.pcc"
1299 } break;
1300 default: {
1301 L31:;
1302 #line 406 "type.pcc"
1303 return polyty;
1304 #line 406 "type.pcc"
1305 } break;
1306 }
1307 } else { goto L31; }
1308 }
1309 #line 407 "type.pcc"
1310 #line 407 "type.pcc"
1311
1312 }
1313
1314 /////////////////////////////////////////////////////////////////////////////
1315 //
1316 // Construct component types
1317 //
1318 /////////////////////////////////////////////////////////////////////////////
1319 Ty component_ty (Ty datatype_ty, Cons cons)
1320 {
1321 #line 416 "type.pcc"
1322 #line 420 "type.pcc"
1323 {
1324 Ty _V12 = deref_all(datatype_ty);
1325 if (_V12) {
1326 switch (_V12->tag__) {
1327 case a_Ty::tag_TYCONty: {
1328 if (cons) {
1329 if (boxed(((Ty_TYCONty *)_V12)->_1)) {
1330 switch (((Ty_TYCONty *)_V12)->_1->tag__) {
1331 case a_TyCon::tag_DATATYPEtycon: {
1332 if (((Ty_TYCONty *)_V12)->_2) {
1333 if (cons) {
1334 if (cons->ty) {
1335 L32:;
1336 #line 418 "type.pcc"
1337 return apply_ty(cons->cons_ty,((Ty_TYCONty *)_V12)->_2);
1338 #line 418 "type.pcc"
1339 } else {
1340 L33:;
1341 #line 419 "type.pcc"
1342 return cons->ty;
1343 #line 419 "type.pcc"
1344 }
1345 } else { goto L33; }
1346 } else { goto L33; }
1347 } break;
1348 default: { goto L33; } break;
1349 }
1350 } else { goto L33; }
1351 } else {
1352 if (boxed(((Ty_TYCONty *)_V12)->_1)) {
1353 switch (((Ty_TYCONty *)_V12)->_1->tag__) {
1354 case a_TyCon::tag_DATATYPEtycon: {
1355 if (((Ty_TYCONty *)_V12)->_2) {
1356 if (cons) {
1357 if (cons->ty) { goto L32; } else {
1358 L34:;
1359 #line 420 "type.pcc"
1360 return NOty;
1361 #line 420 "type.pcc"
1362 }
1363 } else { goto L34; }
1364 } else { goto L34; }
1365 } break;
1366 default: { goto L34; } break;
1367 }
1368 } else { goto L34; }
1369 }
1370 } break;
1371 default: {
1372 L35:;
1373 if (cons) { goto L33; } else { goto L34; }
1374 } break;
1375 }
1376 } else { goto L35; }
1377 }
1378 #line 421 "type.pcc"
1379 #line 421 "type.pcc"
1380
1381 }
1382
1383 /////////////////////////////////////////////////////////////////////////////
1384 //
1385 // Extract record type component
1386 //
1387 /////////////////////////////////////////////////////////////////////////////
1388 Ty component_ty (Ty record_ty, Id label)
1389 {
1390 #line 430 "type.pcc"
1391 #line 441 "type.pcc"
1392 {
1393 Ty _V13 = deref_all(record_ty);
1394 if (_V13) {
1395 switch (_V13->tag__) {
1396 case a_Ty::tag_TYCONty: {
1397 if (boxed(((Ty_TYCONty *)_V13)->_1)) {
1398 switch (((Ty_TYCONty *)_V13)->_1->tag__) {
1399 case a_TyCon::tag_RECORDtycon: {
1400 #line 432 "type.pcc"
1401 Ids ls; Tys ts;
1402 for (ls = ((TyCon_RECORDtycon *)((Ty_TYCONty *)_V13)->_1)->_1, ts = ((Ty_TYCONty *)_V13)->_2; ls && ts; ls = ls->_2, ts = ts->_2)
1403 if (ls->_1 == label) return ts->_1;
1404
1405 #line 435 "type.pcc"
1406 } break;
1407 default: {
1408 L36:; } break;
1409 }
1410 } else {
1411 switch ((int)((Ty_TYCONty *)_V13)->_1) {
1412 case ((int)TUPLEtycon): {
1413 if (
1414 #line 436 "type.pcc"
1415 (label[0] == '_')
1416 #line 436 "type.pcc"
1417 ) {
1418
1419 #line 437 "type.pcc"
1420 int i = atol(label+1);
1421 if (i > 0) return component_ty(_V13,i);
1422
1423 #line 439 "type.pcc"
1424 } else {
1425 goto L36; }
1426 } break;
1427 default: { goto L36; } break;
1428 }
1429 }
1430 } break;
1431 default: { goto L36; } break;
1432 }
1433 } else { goto L36; }
1434 }
1435 #line 441 "type.pcc"
1436 #line 441 "type.pcc"
1437
1438 error("%Ltype %T does not have component %s\n",record_ty,label);
1439 return NOty;
1440 }
1441
1442 /////////////////////////////////////////////////////////////////////////////
1443 //
1444 // Extract tuple type component
1445 //
1446 /////////////////////////////////////////////////////////////////////////////
1447 Ty component_ty (Ty tuple_ty, int n)
1448 {
1449 #line 452 "type.pcc"
1450 #line 459 "type.pcc"
1451 {
1452 Ty _V14 = deref_all(tuple_ty);
1453 if (_V14) {
1454 switch (_V14->tag__) {
1455 case a_Ty::tag_TYCONty: {
1456 if (boxed(((Ty_TYCONty *)_V14)->_1)) {
1457 L37:; } else {
1458 switch ((int)((Ty_TYCONty *)_V14)->_1) {
1459 case ((int)TUPLEtycon): {
1460 #line 454 "type.pcc"
1461 int i; Tys ts;
1462 for (i = 1, ts = ((Ty_TYCONty *)_V14)->_2; ts; ts = ts->_2, i++)
1463 if (i == n) return ts->_1;
1464
1465 #line 457 "type.pcc"
1466 } break;
1467 default: { goto L37; } break;
1468 }
1469 }
1470 } break;
1471 default: { goto L37; } break;
1472 }
1473 } else { goto L37; }
1474 }
1475 #line 459 "type.pcc"
1476 #line 459 "type.pcc"
1477
1478 error("%Ltype %T does not have component #%i\n",tuple_ty,n);
1479 return NOty;
1480 }
1481
1482 /////////////////////////////////////////////////////////////////////////////
1483 //
1484 // Apply type arguments to a ty_scheme.
1485 //
1486 /////////////////////////////////////////////////////////////////////////////
1487 Ty apply_ty (Ty cons_ty, Tys tys)
1488 {
1489 #line 470 "type.pcc"
1490 #line 495 "type.pcc"
1491 {
1492 if (cons_ty) {
1493 switch (cons_ty->tag__) {
1494 case a_Ty::tag_TYCONty: {
1495 if (boxed(((Ty_TYCONty *)cons_ty)->_1)) {
1496 L38:;
1497 #line 495 "type.pcc"
1498 return cons_ty;
1499 #line 495 "type.pcc"
1500 } else {
1501 switch ((int)((Ty_TYCONty *)cons_ty)->_1) {
1502 case ((int)FUNtycon): {
1503 if (((Ty_TYCONty *)cons_ty)->_2) {
1504 #line 494 "type.pcc"
1505 return ((Ty_TYCONty *)cons_ty)->_2->_1;
1506 #line 494 "type.pcc"
1507 } else { goto L38; }
1508 } break;
1509 default: { goto L38; } break;
1510 }
1511 }
1512 } break;
1513 case a_Ty::tag_POLYty: {
1514 #line 472 "type.pcc"
1515 Ty subst[256]; int i; Tys ts;
1516 for (i = 0, ts = tys; i < ((Ty_POLYty *)cons_ty)->_2 && ts; i++, ts = ts->_2)
1517 subst[i] = ts->_1;
1518 if (ts !=
1519 #line 475 "type.pcc"
1520 #line 475 "type.pcc"
1521 nil_1_
1522 #line 475 "type.pcc"
1523 #line 475 "type.pcc"
1524 )
1525 {error("%Ltoo many arguments %P in instantiation of type scheme %T\n",
1526 tys, cons_ty);
1527 return NOty;
1528 }
1529 if (i != ((Ty_POLYty *)cons_ty)->_2)
1530 {error("%Ltoo few arguments %P in instantiation of type scheme %T\n",
1531 tys, cons_ty);
1532 return NOty;
1533 }
1534 Ty t = inst(((Ty_POLYty *)cons_ty)->_1, ((Ty_POLYty *)cons_ty)->_2, ((Ty_POLYty *)cons_ty)->_3, subst);
1535
1536 #line 486 "type.pcc"
1537 #line 491 "type.pcc"
1538 {
1539 Ty _V15 = deref(t);
1540 if (_V15) {
1541 switch (_V15->tag__) {
1542 case a_Ty::tag_TYCONty: {
1543 if (boxed(((Ty_TYCONty *)_V15)->_1)) {
1544 L39:;
1545 #line 488 "type.pcc"
1546 return _V15;
1547 #line 488 "type.pcc"
1548 } else {
1549 switch ((int)((Ty_TYCONty *)_V15)->_1) {
1550 case ((int)FUNtycon): {
1551 if (((Ty_TYCONty *)_V15)->_2) {
1552 if (((Ty_TYCONty *)_V15)->_2->_2) {
1553 if (((Ty_TYCONty *)_V15)->_2->_2->_2) { goto L39; } else {
1554 #line 487 "type.pcc"
1555 return ((Ty_TYCONty *)_V15)->_2->_1;
1556 #line 487 "type.pcc"
1557 }
1558 } else { goto L39; }
1559 } else { goto L39; }
1560 } break;
1561 default: { goto L39; } break;
1562 }
1563 }
1564 } break;
1565 default: {
1566 L40:;
1567 #line 489 "type.pcc"
1568 error ("%Lbad constructor type %T\n",cons_ty);
1569 return NOty;
1570
1571 #line 491 "type.pcc"
1572 } break;
1573 }
1574 } else { goto L40; }
1575 }
1576 #line 492 "type.pcc"
1577 #line 492 "type.pcc"
1578
1579
1580 #line 493 "type.pcc"
1581 } break;
1582 default: { goto L38; } break;
1583 }
1584 } else { goto L38; }
1585 }
1586 #line 496 "type.pcc"
1587 #line 496 "type.pcc"
1588
1589 }
1590
1591 /////////////////////////////////////////////////////////////////////////////
1592 //
1593 // Unify two type constructors
1594 //
1595 /////////////////////////////////////////////////////////////////////////////
1596 Bool unify(TyCon a, TyCon b)
1597 {
1598 #line 505 "type.pcc"
1599 #line 520 "type.pcc"
1600 {
1601 if (boxed(a)) {
1602 switch (a->tag__) {
1603 case a_TyCon::tag_IDtycon: {
1604 if (boxed(b)) {
1605 switch (b->tag__) {
1606 case a_TyCon::tag_IDtycon: {
1607 #line 509 "type.pcc"
1608 return ((TyCon_IDtycon *)a)->IDtycon == ((TyCon_IDtycon *)b)->IDtycon;
1609 #line 509 "type.pcc"
1610 } break;
1611 default: {
1612 L41:;
1613 #line 520 "type.pcc"
1614 return false;
1615 #line 520 "type.pcc"
1616 } break;
1617 }
1618 } else { goto L41; }
1619 } break;
1620 case a_TyCon::tag_ARRAYtycon: {
1621 L42:;
1622 if (boxed(b)) {
1623 switch (b->tag__) {
1624 case a_TyCon::tag_ARRAYtycon: {
1625 L43:;
1626 #line 507 "type.pcc"
1627 return true;
1628 #line 507 "type.pcc"
1629 } break;
1630 default: { goto L41; } break;
1631 }
1632 } else {
1633 switch ((int)b) {
1634 case ((int)POINTERtycon): { goto L43; } break;
1635 default: { goto L41; } break;
1636 }
1637 }
1638 } break;
1639 case a_TyCon::tag_BITFIELDtycon: {
1640 if (boxed(b)) {
1641 switch (b->tag__) {
1642 case a_TyCon::tag_BITFIELDtycon: {
1643 #line 519 "type.pcc"
1644 return ((TyCon_BITFIELDtycon *)a)->width == ((TyCon_BITFIELDtycon *)b)->width && ((TyCon_BITFIELDtycon *)a)->is_signed == ((TyCon_BITFIELDtycon *)b)->is_signed;
1645 #line 519 "type.pcc"
1646 } break;
1647 default: { goto L41; } break;
1648 }
1649 } else { goto L41; }
1650 } break;
1651 case a_TyCon::tag_DATATYPEtycon: {
1652 if (boxed(b)) {
1653 switch (b->tag__) {
1654 case a_TyCon::tag_DATATYPEtycon: {
1655 #line 514 "type.pcc"
1656 return a == b;
1657 #line 514 "type.pcc"
1658 } break;
1659 default: { goto L41; } break;
1660 }
1661 } else { goto L41; }
1662 } break;
1663 case a_TyCon::tag_COLtycon: {
1664 if (boxed(b)) {
1665 switch (b->tag__) {
1666 case a_TyCon::tag_COLtycon: {
1667 #line 516 "type.pcc"
1668 return ((TyCon_COLtycon *)a)->COLtycon->name == ((TyCon_COLtycon *)b)->COLtycon->name;
1669 #line 516 "type.pcc"
1670 } break;
1671 default: { goto L41; } break;
1672 }
1673 } else { goto L41; }
1674 } break;
1675 default: { goto L41; } break;
1676 }
1677 } else {
1678 switch ((int)a) {
1679 case ((int)POINTERtycon): { goto L42; } break;
1680 case ((int)REFtycon): {
1681 if (boxed(b)) { goto L41; } else {
1682 switch ((int)b) {
1683 case ((int)REFtycon): {
1684 #line 508 "type.pcc"
1685 return true;
1686 #line 508 "type.pcc"
1687 } break;
1688 default: { goto L41; } break;
1689 }
1690 }
1691 } break;
1692 case ((int)TUPLEtycon): {
1693 if (boxed(b)) { goto L41; } else {
1694 switch ((int)b) {
1695 case ((int)TUPLEtycon): {
1696 #line 510 "type.pcc"
1697 return true;
1698 #line 510 "type.pcc"
1699 } break;
1700 default: { goto L41; } break;
1701 }
1702 }
1703 } break;
1704 case ((int)EXTUPLEtycon): {
1705 if (boxed(b)) { goto L41; } else {
1706 switch ((int)b) {
1707 case ((int)EXTUPLEtycon): {
1708 #line 511 "type.pcc"
1709 return true;
1710 #line 511 "type.pcc"
1711 } break;
1712 default: { goto L41; } break;
1713 }
1714 }
1715 } break;
1716 case ((int)FUNtycon): {
1717 if (boxed(b)) { goto L41; } else {
1718 switch ((int)b) {
1719 case ((int)FUNtycon): {
1720 #line 513 "type.pcc"
1721 return true;
1722 #line 513 "type.pcc"
1723 } break;
1724 default: { goto L41; } break;
1725 }
1726 }
1727 } break;
1728 default: {
1729 if (boxed(b)) { goto L41; } else {
1730 switch ((int)b) {
1731 case ((int)TYPEtycon): {
1732 #line 512 "type.pcc"
1733 return true;
1734 #line 512 "type.pcc"
1735 } break;
1736 default: { goto L41; } break;
1737 }
1738 }
1739 } break;
1740 }
1741 }
1742 }
1743 #line 521 "type.pcc"
1744 #line 521 "type.pcc"
1745
1746 }
1747
1748 /////////////////////////////////////////////////////////////////////////////
1749 //
1750 // Unify two record types
1751 //
1752 /////////////////////////////////////////////////////////////////////////////
1753 Bool unify_record
1754 (Ty u, Ids& x, Tys& a, Bool& f,
1755 Ty v, Ids& y, Tys& b, Bool& g, Bool again = true)
1756 { Ids i, j;
1757 Tys p, q;
1758 Bool ok = true;
1759
1760 for (i = x, p = a; i; i = i->_2, p = p->_2) {
1761 Bool b_found = false;
1762 for (j = y, q = b; j; j = j->_2, q = q->_2) {
1763 if (i->_1 == j->_1) {
1764 if (b_found) {
1765 error ("%Lduplicated label '%s' in type %T\n", i->_1, v);
1766 ok = false;
1767 }
1768 b_found = true;
1769 if (! unify(p->_1, q->_1)) ok = false;
1770 }
1771 }
1772 if (! b_found && ! g) {
1773 error ("%L%s label '%s' in type %T\n",
1774 (again ? "missing" : "extra"), i->_1, v);
1775 ok = false;
1776 }
1777 }
1778
1779 // unify in the other direction if not flexible
1780 if (again && ! f) unify_record(v,y,b,g,u,x,a,f,false);
1781
1782 if (! f && g) { y = x; b = a; }
1783 if (! g && f) { x = y; a = b; }
1784
1785 if (! f) g = false;
1786 if (! g) f = false;
1787
1788 return ok;
1789 }
1790
1791 /////////////////////////////////////////////////////////////////////////////
1792 //
1793 // Occurs check
1794 //
1795 /////////////////////////////////////////////////////////////////////////////
1796 Bool occurs (Ty ty, Ty tyvar)
1797 {
1798 #line 573 "type.pcc"
1799 #line 579 "type.pcc"
1800 {
1801 Ty _V16 = deref_all(ty);
1802 if (_V16) {
1803 switch (_V16->tag__) {
1804 case a_Ty::tag_VARty: {
1805 if (
1806 #line 574 "type.pcc"
1807 (tyvar == _V16)
1808 #line 574 "type.pcc"
1809 ) {
1810
1811 #line 574 "type.pcc"
1812 return true;
1813 #line 574 "type.pcc"
1814 } else {
1815
1816 L44:;
1817 #line 579 "type.pcc"
1818 return false;
1819 #line 579 "type.pcc"
1820 }
1821 } break;
1822 case a_Ty::tag_TYCONty: {
1823 #line 576 "type.pcc"
1824 for_each(Ty, t, ((Ty_TYCONty *)_V16)->_2) if (occurs(t,tyvar)) return true;
1825 return false;
1826
1827 #line 578 "type.pcc"
1828 } break;
1829 default: { goto L44; } break;
1830 }
1831 } else { goto L44; }
1832 }
1833 #line 580 "type.pcc"
1834 #line 580 "type.pcc"
1835
1836 }
1837
1838 /////////////////////////////////////////////////////////////////////////////
1839 //
1840 // Unify two types. Returns true iff unification succeeds.
1841 //
1842 /////////////////////////////////////////////////////////////////////////////
1843 Bool unify (Ty t1, Ty t2)
1844 {
1845 #line 589 "type.pcc"
1846 #line 613 "type.pcc"
1847 {
1848 Ty _V17 = deref(t1);
1849 Ty _V18 = deref(t2);
1850 if (
1851 #line 591 "type.pcc"
1852 (_V17 == _V18)
1853 #line 591 "type.pcc"
1854 ) {
1855
1856 if (_V17) {
1857 if (_V18) {
1858 L45:;
1859 #line 591 "type.pcc"
1860 return true;
1861 #line 591 "type.pcc"
1862 } else {
1863 L46:;
1864 #line 590 "type.pcc"
1865 return false;
1866 #line 590 "type.pcc"
1867 }
1868 } else { goto L46; }
1869 } else {
1870
1871 if (_V17) {
1872 switch (_V17->tag__) {
1873 case a_Ty::tag_VARty: {
1874 if (_V18) {
1875 switch (_V18->tag__) {
1876 case a_Ty::tag_VARty: {
1877 L47:;
1878 #line 593 "type.pcc"
1879 if (occurs(_V17,_V18)) {
1880 error ("%Lunification fails occurs check with %T and %T\n",t1,t2);
1881 return false;
1882 } else { ((Ty_VARty *)_V18)->VARty = _V17; return true; }
1883
1884 #line 597 "type.pcc"
1885 } break;
1886 default: {
1887 #line 599 "type.pcc"
1888 if (occurs(_V18,_V17)) {
1889 error ("%Lunification fails occurs check with %T and %T\n",t1,t2);
1890 return false;
1891 } else { ((Ty_VARty *)_V17)->VARty = _V18; return true; }
1892
1893 #line 603 "type.pcc"
1894 } break;
1895 }
1896 } else { goto L46; }
1897 } break;
1898 default: {
1899 if (_V18) {
1900 switch (_V18->tag__) {
1901 case a_Ty::tag_VARty: { goto L47; } break;
1902 default: {
1903 L48:;
1904 #line 605 "type.pcc"
1905
1906 #line 605 "type.pcc"
1907 #line 611 "type.pcc"
1908 {
1909 Ty _V19 = deref_all(t1);
1910 Ty _V20 = deref_all(t2);
1911 if (
1912 #line 606 "type.pcc"
1913 (_V19 == _V20)
1914 #line 606 "type.pcc"
1915 ) {
1916
1917 #line 606 "type.pcc"
1918 return true;
1919 #line 606 "type.pcc"
1920 } else {
1921
1922 if (_V19) {
1923 switch (_V19->tag__) {
1924 case a_Ty::tag_TYCONty: {
1925 if (_V20) {
1926 switch (_V20->tag__) {
1927 case a_Ty::tag_TYCONty: {
1928 if (boxed(((Ty_TYCONty *)_V19)->_1)) {
1929 switch (((Ty_TYCONty *)_V19)->_1->tag__) {
1930 case a_TyCon::tag_RECORDtycon: {
1931 if (_V20) {
1932 switch (_V20->tag__) {
1933 case a_Ty::tag_TYCONty: {
1934 if (boxed(((Ty_TYCONty *)_V20)->_1)) {
1935 switch (((Ty_TYCONty *)_V20)->_1->tag__) {
1936 case a_TyCon::tag_RECORDtycon: {
1937 L49:;
1938 #line 608 "type.pcc"
1939 return unify_record(t1,((TyCon_RECORDtycon *)((Ty_TYCONty *)_V19)->_1)->_1,((Ty_TYCONty *)_V19)->_2,((TyCon_RECORDtycon *)((Ty_TYCONty *)_V19)->_1)->_2,t2,((TyCon_RECORDtycon *)((Ty_TYCONty *)_V20)->_1)->_1,((Ty_TYCONty *)_V20)->_2,((TyCon_RECORDtycon *)((Ty_TYCONty *)_V20)->_1)->_2);
1940 #line 608 "type.pcc"
1941 } break;
1942 default: {
1943 L50:;
1944 #line 609 "type.pcc"
1945 return unify(((Ty_TYCONty *)_V19)->_1,((Ty_TYCONty *)_V20)->_1) && unify(((Ty_TYCONty *)_V19)->_2,((Ty_TYCONty *)_V20)->_2);
1946 #line 609 "type.pcc"
1947 } break;
1948 }
1949 } else { goto L50; }
1950 } break;
1951 default: { goto L50; } break;
1952 }
1953 } else { goto L50; }
1954 } break;
1955 default: { goto L50; } break;
1956 }
1957 } else { goto L50; }
1958 } break;
1959 default: {
1960 L51:;
1961 if (boxed(((Ty_TYCONty *)_V19)->_1)) {
1962 switch (((Ty_TYCONty *)_V19)->_1->tag__) {
1963 case a_TyCon::tag_RECORDtycon: {
1964 L52:;
1965 if (_V20) {
1966 switch (_V20->tag__) {
1967 case a_Ty::tag_TYCONty: {
1968 L53:;
1969 if (boxed(((Ty_TYCONty *)_V20)->_1)) {
1970 switch (((Ty_TYCONty *)_V20)->_1->tag__) {
1971 case a_TyCon::tag_RECORDtycon: { goto L49; } break;
1972 default: {
1973 L54:;
1974 #line 611 "type.pcc"
1975 return false;
1976 #line 611 "type.pcc"
1977 } break;
1978 }
1979 } else { goto L54; }
1980 } break;
1981 default: { goto L54; } break;
1982 }
1983 } else { goto L54; }
1984 } break;
1985 default: { goto L54; } break;
1986 }
1987 } else { goto L54; }
1988 } break;
1989 }
1990 } else { goto L51; }
1991 } break;
1992 case a_Ty::tag_NESTEDty: {
1993 if (_V20) {
1994 switch (_V20->tag__) {
1995 case a_Ty::tag_NESTEDty: {
1996 #line 610 "type.pcc"
1997 return unify(((Ty_NESTEDty *)_V19)->_1,((Ty_NESTEDty *)_V20)->_1) && unify(((Ty_NESTEDty *)_V19)->_2,((Ty_NESTEDty *)_V20)->_2);
1998 #line 610 "type.pcc"
1999 } break;
2000 default: { goto L54; } break;
2001 }
2002 } else { goto L54; }
2003 } break;
2004 default: { goto L54; } break;
2005 }
2006 } else { goto L54; }
2007 }
2008 }
2009 #line 612 "type.pcc"
2010 #line 612 "type.pcc"
2011
2012
2013 #line 613 "type.pcc"
2014 } break;
2015 }
2016 } else { goto L46; }
2017 } break;
2018 }
2019 } else { goto L46; }
2020 }
2021 }
2022 #line 614 "type.pcc"
2023 #line 614 "type.pcc"
2024
2025 }
2026
2027 /////////////////////////////////////////////////////////////////////////////
2028 //
2029 // Unify two type lists.
2030 //
2031 /////////////////////////////////////////////////////////////////////////////
2032 Bool unify(Tys xs, Tys ys)
2033 { Bool ok = true;
2034
2035 #line 624 "type.pcc"
2036 #line 626 "type.pcc"
2037 {
2038 for (;;) {
2039 if (xs) {
2040 if (ys) {
2041 #line 626 "type.pcc"
2042 if (! unify(xs->_1, ys->_1)) ok = false; xs = xs->_2; ys = ys->_2;
2043 #line 626 "type.pcc"
2044 } else { goto L55; }
2045 } else { goto L55; }
2046 }
2047 L55:;
2048 }
2049 #line 627 "type.pcc"
2050 #line 627 "type.pcc"
2051
2052 return ok && xs ==
2053 #line 628 "type.pcc"
2054 #line 628 "type.pcc"
2055 nil_1_
2056 #line 628 "type.pcc"
2057 #line 628 "type.pcc"
2058 && ys ==
2059 #line 628 "type.pcc"
2060 #line 628 "type.pcc"
2061 nil_1_
2062 #line 628 "type.pcc"
2063 #line 628 "type.pcc"
2064 ;
2065 }
2066
2067 /////////////////////////////////////////////////////////////////////////////
2068 //
2069 // Unify two types and print error message if fails.
2070 //
2071 /////////////////////////////////////////////////////////////////////////////
2072 Bool unify(Pat p, Ty a, Ty b)
2073 { if (! unify(a,b))
2074 { error ("%Ltype mismatch in pattern: %p\n"
2075 "%Lexpecting '%T' but found '%T'\n", p, a, b);
2076 return false;
2077 }
2078 return true;
2079 }
2080
2081 /////////////////////////////////////////////////////////////////////////////
2082 //
2083 // Infer the type of literals
2084 //
2085 /////////////////////////////////////////////////////////////////////////////
2086 Ty type_of (Literal l)
2087 {
2088 #line 651 "type.pcc"
2089 #line 658 "type.pcc"
2090 {
2091 switch (l->tag__) {
2092 case a_Literal::tag_INTlit: {
2093 #line 652 "type.pcc"
2094 return integer_ty;
2095 #line 652 "type.pcc"
2096 } break;
2097 case a_Literal::tag_BOOLlit: {
2098 #line 654 "type.pcc"
2099 return bool_ty;
2100 #line 654 "type.pcc"
2101 } break;
2102 case a_Literal::tag_CHARlit: {
2103 #line 653 "type.pcc"
2104 return character_ty;
2105 #line 653 "type.pcc"
2106 } break;
2107 case a_Literal::tag_REALlit: {
2108 #line 655 "type.pcc"
2109 return real_ty;
2110 #line 655 "type.pcc"
2111 } break;
2112 case a_Literal::tag_QUARKlit: {
2113 #line 656 "type.pcc"
2114 return quark_ty;
2115 #line 656 "type.pcc"
2116 } break;
2117 case a_Literal::tag_BIGINTlit: {
2118 #line 657 "type.pcc"
2119 return bigint_ty;
2120 #line 657 "type.pcc"
2121 } break;
2122 default: {
2123 #line 658 "type.pcc"
2124 return string_ty;
2125 #line 658 "type.pcc"
2126 } break;
2127 }
2128 }
2129 #line 659 "type.pcc"
2130 #line 659 "type.pcc"
2131
2132 }
2133
2134 /////////////////////////////////////////////////////////////////////////////
2135 //
2136 // Additional pattern variable type map.
2137 //
2138 /////////////////////////////////////////////////////////////////////////////
2139 HashTable * patvar_typemap = 0;
2140
2141 /////////////////////////////////////////////////////////////////////////////
2142 //
2143 // Infer the type of a pattern.
2144 //
2145 /////////////////////////////////////////////////////////////////////////////
2146 Ty type_of (Pat pat)
2147 { Ty t = NOty;
2148
2149 #line 676 "type.pcc"
2150 #line 752 "type.pcc"
2151 {
2152 if (pat) {
2153 switch (pat->tag__) {
2154 case a_Pat::tag_WILDpat: {
2155 #line 678 "type.pcc"
2156 t = mkvar();
2157 #line 678 "type.pcc"
2158 } break;
2159 case a_Pat::tag_INDpat: {
2160 #line 679 "type.pcc"
2161 t = ((Pat_INDpat *)pat)->_3;
2162 #line 679 "type.pcc"
2163 } break;
2164 case a_Pat::tag_IDpat: {
2165 #line 681 "type.pcc"
2166 t = ((Pat_IDpat *)pat)->_2;
2167 // If we have a pattern variable type map
2168 // also use it.
2169 if (patvar_typemap)
2170 { HashTable::Entry * e = patvar_typemap->lookup(((Pat_IDpat *)pat)->_1);
2171 if (e)
2172 { Ty nonterm_ty = Ty(e->v);
2173 if (!unify(nonterm_ty,((Pat_IDpat *)pat)->_2))
2174 { error("%Lexpecting non-terminal %s to have type %T but found %T\n",
2175 ((Pat_IDpat *)pat)->_1, nonterm_ty, ((Pat_IDpat *)pat)->_2);
2176 }
2177 }
2178 }
2179
2180 #line 694 "type.pcc"
2181 } break;
2182 case a_Pat::tag_CONSpat: {
2183 if (((Pat_CONSpat *)pat)->CONSpat) {
2184 #line 736 "type.pcc"
2185 t = inst(((Pat_CONSpat *)pat)->CONSpat->cons_ty);
2186 #line 736 "type.pcc"
2187 } else {
2188 #line 737 "type.pcc"
2189 errors++; t = mkvar();
2190 #line 737 "type.pcc"
2191 }
2192 } break;
2193 case a_Pat::tag_APPpat: {
2194 #line 739 "type.pcc"
2195 Ty fun_ty = type_of(((Pat_APPpat *)pat)->_1);
2196 Ty range = mkvar();
2197 unify(pat,fun_ty,mkfunty(type_of(((Pat_APPpat *)pat)->_2), range));
2198 t = deref(range);
2199
2200 #line 743 "type.pcc"
2201 } break;
2202 case a_Pat::tag_TYPEDpat: {
2203 #line 734 "type.pcc"
2204 t = type_of(((Pat_TYPEDpat *)pat)->_1); unify(((Pat_TYPEDpat *)pat)->_1,((Pat_TYPEDpat *)pat)->_2,t);
2205 #line 734 "type.pcc"
2206 } break;
2207 case a_Pat::tag_ASpat: {
2208 #line 695 "type.pcc"
2209 t = type_of(((Pat_ASpat *)pat)->_2); unify(pat,((Pat_ASpat *)pat)->_3,t);
2210 #line 695 "type.pcc"
2211 } break;
2212 case a_Pat::tag_LITERALpat: {
2213 #line 697 "type.pcc"
2214 t = type_of(((Pat_LITERALpat *)pat)->LITERALpat);
2215 #line 697 "type.pcc"
2216 } break;
2217 case a_Pat::tag_CONTEXTpat: {
2218 #line 702 "type.pcc"
2219 t = type_of(((Pat_CONTEXTpat *)pat)->_2);
2220 #line 702 "type.pcc"
2221 } break;
2222 case a_Pat::tag_LEXEMEpat: {
2223 #line 698 "type.pcc"
2224 t = string_ty;
2225 #line 698 "type.pcc"
2226 } break;
2227 case a_Pat::tag_ARRAYpat: {
2228 #line 711 "type.pcc"
2229 Ty ty = mkvar();
2230 for_each(Pat,p,((Pat_ARRAYpat *)pat)->_1) unify(pat,ty,type_of(p));
2231 t = mkptrty(QUALty(QUALconst,ty));
2232
2233 #line 714 "type.pcc"
2234 } break;
2235 case a_Pat::tag_TUPLEpat: {
2236 #line 699 "type.pcc"
2237 t = mktuplety(type_of(((Pat_TUPLEpat *)pat)->TUPLEpat));
2238 #line 699 "type.pcc"
2239 } break;
2240 case a_Pat::tag_EXTUPLEpat: {
2241 #line 700 "type.pcc"
2242 t = TYCONty(EXTUPLEtycon,type_of(((Pat_EXTUPLEpat *)pat)->EXTUPLEpat));
2243 #line 700 "type.pcc"
2244 } break;
2245 case a_Pat::tag_RECORDpat: {
2246 #line 703 "type.pcc"
2247 t = mkrecordty(labels_of(((Pat_RECORDpat *)pat)->_1),type_of(((Pat_RECORDpat *)pat)->_1),((Pat_RECORDpat *)pat)->_2);
2248 #line 703 "type.pcc"
2249 } break;
2250 case a_Pat::tag_LISTpat: {
2251 if (((Pat_LISTpat *)pat)->head) {
2252 #line 749 "type.pcc"
2253 t = type_of(APPpat(CONSpat(((Pat_LISTpat *)pat)->cons),
2254 TUPLEpat(
2255 #line 750 "type.pcc"
2256 #line 750 "type.pcc"
2257 list_1_(((Pat_LISTpat *)pat)->head->_1,list_1_(LISTpat(((Pat_LISTpat *)pat)->cons,((Pat_LISTpat *)pat)->nil,((Pat_LISTpat *)pat)->head->_2,((Pat_LISTpat *)pat)->tail)))
2258 #line 750 "type.pcc"
2259 #line 750 "type.pcc"
2260 )));
2261
2262 #line 751 "type.pcc"
2263 } else {
2264 if (((Pat_LISTpat *)pat)->tail) {
2265 #line 747 "type.pcc"
2266 t = type_of(((Pat_LISTpat *)pat)->tail);
2267 #line 747 "type.pcc"
2268 } else {
2269 #line 745 "type.pcc"
2270 t = type_of(CONSpat(((Pat_LISTpat *)pat)->nil));
2271 #line 745 "type.pcc"
2272 }
2273 }
2274 } break;
2275 case a_Pat::tag_VECTORpat: {
2276 #line 716 "type.pcc"
2277 Ty arg_ty = mkvar();
2278 for_each(Pat,p,((Pat_VECTORpat *)pat)->elements) unify(pat,arg_ty,type_of(p));
2279 Ty vec_ty = type_of(CONSpat(((Pat_VECTORpat *)pat)->cons));
2280 Ty range_ty = mkvar();
2281 if (((Pat_VECTORpat *)pat)->len != NOpat)
2282 unify(pat,integer_ty,type_of(((Pat_VECTORpat *)pat)->len));
2283 if (((Pat_VECTORpat *)pat)->array != NOpat)
2284 unify(pat,mkptrty(arg_ty),type_of(((Pat_VECTORpat *)pat)->array));
2285 unify(pat,vec_ty,mkfunty(arg_ty, range_ty));
2286 t = deref(range_ty);
2287
2288 #line 726 "type.pcc"
2289 } break;
2290 case a_Pat::tag_APPENDpat: {
2291 #line 705 "type.pcc"
2292 Ty t1 = type_of(((Pat_APPENDpat *)pat)->_1);
2293 Ty t2 = type_of(((Pat_APPENDpat *)pat)->_2);
2294 t = ((Pat_APPENDpat *)pat)->_3 = t1;
2295 unify(pat,t1,t2);
2296
2297 #line 709 "type.pcc"
2298 } break;
2299 case a_Pat::tag_GUARDpat: {
2300 #line 701 "type.pcc"
2301 t = type_of(((Pat_GUARDpat *)pat)->_1);
2302 #line 701 "type.pcc"
2303 } break;
2304 case a_Pat::tag_LOGICALpat: {
2305 switch (((Pat_LOGICALpat *)pat)->_1) {
2306 case NOTpat: {
2307 #line 727 "type.pcc"
2308 t = type_of(((Pat_LOGICALpat *)pat)->_2);
2309 #line 727 "type.pcc"
2310 } break;
2311 default: {
2312 #line 728 "type.pcc"
2313 Ty ty1 = type_of(((Pat_LOGICALpat *)pat)->_2);
2314 Ty ty2 = type_of(((Pat_LOGICALpat *)pat)->_3);
2315 unify(pat,ty1,ty2);
2316 t = ty1;
2317
2318 #line 732 "type.pcc"
2319 } break;
2320 }
2321 } break;
2322 case a_Pat::tag_UNIFYpat: {
2323 #line 696 "type.pcc"
2324 t = type_of(((Pat_UNIFYpat *)pat)->_1);
2325 #line 696 "type.pcc"
2326 } break;
2327 case a_Pat::tag_MARKEDpat: {
2328 #line 735 "type.pcc"
2329 t = type_of(((Pat_MARKEDpat *)pat)->_2);
2330 #line 735 "type.pcc"
2331 } break;
2332 default: {
2333 #line 752 "type.pcc"
2334 bug("type_of(Pat)");
2335 #line 752 "type.pcc"
2336 } break;
2337 }
2338 } else {
2339 #line 677 "type.pcc"
2340 t = NOty;
2341 #line 677 "type.pcc"
2342 }
2343 }
2344 #line 753 "type.pcc"
2345 #line 753 "type.pcc"
2346
2347 if (boxed(pat)) pat->ty = t;
2348 return t;
2349 }
2350
2351 /////////////////////////////////////////////////////////////////////////////
2352 //
2353 // Infer the type of a pattern list.
2354 //
2355 /////////////////////////////////////////////////////////////////////////////
2356 Tys type_of(Pats ps)
2357 {
2358 #line 764 "type.pcc"
2359 #line 766 "type.pcc"
2360 {
2361 if (ps) {
2362 #line 766 "type.pcc"
2363 return
2364 #line 766 "type.pcc"
2365 #line 766 "type.pcc"
2366 list_1_(type_of(ps->_1),type_of(ps->_2))
2367 #line 766 "type.pcc"
2368 #line 766 "type.pcc"
2369 ;
2370 #line 766 "type.pcc"
2371 } else {
2372 #line 765 "type.pcc"
2373 return
2374 #line 765 "type.pcc"
2375 #line 765 "type.pcc"
2376 nil_1_
2377 #line 765 "type.pcc"
2378 #line 765 "type.pcc"
2379 ;
2380 #line 765 "type.pcc"
2381 }
2382 }
2383 #line 767 "type.pcc"
2384 #line 767 "type.pcc"
2385
2386 }
2387
2388 /////////////////////////////////////////////////////////////////////////////
2389 //
2390 // Infer the type of a labeled pattern list.
2391 //
2392 /////////////////////////////////////////////////////////////////////////////
2393 Tys type_of(LabPats ps)
2394 {
2395 #line 776 "type.pcc"
2396 #line 778 "type.pcc"
2397 {
2398 if (ps) {
2399 #line 778 "type.pcc"
2400 return
2401 #line 778 "type.pcc"
2402 #line 778 "type.pcc"
2403 list_1_(type_of(ps->_1.pat),type_of(ps->_2))
2404 #line 778 "type.pcc"
2405 #line 778 "type.pcc"
2406 ;
2407 #line 778 "type.pcc"
2408 } else {
2409 #line 777 "type.pcc"
2410 return
2411 #line 777 "type.pcc"
2412 #line 777 "type.pcc"
2413 nil_1_
2414 #line 777 "type.pcc"
2415 #line 777 "type.pcc"
2416 ;
2417 #line 777 "type.pcc"
2418 }
2419 }
2420 #line 779 "type.pcc"
2421 #line 779 "type.pcc"
2422
2423 }
2424
2425 /////////////////////////////////////////////////////////////////////////////
2426 //
2427 // Get the list of labels from a labeled pattern list.
2428 //
2429 /////////////////////////////////////////////////////////////////////////////
2430 Ids labels_of(LabPats ps)
2431 {
2432 #line 788 "type.pcc"
2433 #line 790 "type.pcc"
2434 {
2435 if (ps) {
2436 #line 790 "type.pcc"
2437 return
2438 #line 790 "type.pcc"
2439 #line 790 "type.pcc"
2440 list_1_(ps->_1.label,labels_of(ps->_2))
2441 #line 790 "type.pcc"
2442 #line 790 "type.pcc"
2443 ;
2444 #line 790 "type.pcc"
2445 } else {
2446 #line 789 "type.pcc"
2447 return
2448 #line 789 "type.pcc"
2449 #line 789 "type.pcc"
2450 nil_1_
2451 #line 789 "type.pcc"
2452 #line 789 "type.pcc"
2453 ;
2454 #line 789 "type.pcc"
2455 }
2456 }
2457 #line 791 "type.pcc"
2458 #line 791 "type.pcc"
2459
2460 }
2461
2462 /////////////////////////////////////////////////////////////////////////////
2463 //
2464 // Infer the type of a set of pattern rules.
2465 //
2466 /////////////////////////////////////////////////////////////////////////////
2467 Ty type_match_rules(MatchRules rules)
2468 { Bool ok = true;
2469 MEM::use_global_pools();
2470 Ty ty = mkvar();
2471 for_each(MatchRule, r, rules)
2472 {
2473 #line 804 "type.pcc"
2474 #line 813 "type.pcc"
2475 {
2476 #line 806 "type.pcc"
2477 r->set_loc();
2478 Ty this_ty = type_of(r->_2);
2479 if (this_ty == NOty)
2480 { error ("%!type error in pattern %p: %T\n",
2481 r->loc(), r->_2, this_ty);
2482 ok = false;
2483 } else if (! unify(r->_2,ty,this_ty)) ok = false;
2484
2485 #line 813 "type.pcc"
2486 }
2487 #line 814 "type.pcc"
2488 #line 814 "type.pcc"
2489
2490 }
2491 MEM::use_local_pools();
2492 return ok ? ty : NOty;
2493 }
2494
2495 /////////////////////////////////////////////////////////////////////////////
2496 //
2497 // The type and constructor environments (both are flat for now.)
2498 //
2499 /////////////////////////////////////////////////////////////////////////////
2500 HashTable ty_env(string_hash,string_equal,91);
2501 HashTable cons_env(string_hash,string_equal,129);
2502 HashTable token_env(string_hash,string_equal,129);
2503
2504 /////////////////////////////////////////////////////////////////////////////
2505 //
2506 // Lookup the type from its name.
2507 //
2508 /////////////////////////////////////////////////////////////////////////////
2509 Ty lookup_ty(Id id)
2510 { HashTable::Entry * i = ty_env.lookup(id);
2511 return i ? inst(value_of(Ty,ty_env,i)) : NOty;
2512 }
2513
2514 /////////////////////////////////////////////////////////////////////////////
2515 //
2516 // Lookup the constructor from its name.
2517 //
2518 /////////////////////////////////////////////////////////////////////////////
2519 Cons lookup_cons(Id id)
2520 { Cons c = find_cons(id);
2521 if (c == NOcons)
2522 { error ("%Lconstructor '%s' is undefined\n", id);
2523 }
2524 return c;
2525 }
2526
2527 Cons lookup_token (Id id)
2528 { Cons c = NOcons;
2529 HashTable::Entry * i = token_env.lookup(id);
2530 if (i) return (Cons)i->v;
2531 c = find_cons(id);
2532 if (c == NOcons)
2533 { if (id[0] == '"')
2534 error ("%Llexeme %s is undefined\n", id);
2535 else
2536 error ("%Lconstructor '%s' is undefined\n", id);
2537 }
2538 return c;
2539 }
2540
2541 Cons find_cons(Id id)
2542 { HashTable::Entry * i = cons_env.lookup(id);
2543 return i ? value_of(Cons,cons_env,i) : NOcons;
2544 }
2545
2546 /////////////////////////////////////////////////////////////////////////////
2547 //
2548 // Add a new type to the environment.
2549 //
2550 /////////////////////////////////////////////////////////////////////////////
2551 void add_type(Id id, TyVars tyvars, Ty ty)
2552 { HashTable::Entry * i = ty_env.lookup(id);
2553 if (i) {
2554 error("%Ltype %s has already been defined as %T\n",
2555 id, value_of(Ty,ty_env,i));
2556 } else {
2557
2558 #line 882 "type.pcc"
2559 #line 886 "type.pcc"
2560 {
2561 Ty _V21 = deref_all(ty);
2562 if (_V21) {
2563 switch (_V21->tag__) {
2564 case a_Ty::tag_TYCONty: {
2565 if (boxed(((Ty_TYCONty *)_V21)->_1)) {
2566 switch (((Ty_TYCONty *)_V21)->_1->tag__) {
2567 case a_TyCon::tag_IDtycon: {
2568 if (
2569 #line 883 "type.pcc"
2570 (((TyCon_IDtycon *)((Ty_TYCONty *)_V21)->_1)->IDtycon == id)
2571 #line 883 "type.pcc"
2572 ) {
2573
2574 #line 884 "type.pcc"
2575 error("%Lcyclic type definition in type %s%V = %T\n",id,tyvars,ty);
2576
2577 #line 885 "type.pcc"
2578 } else {
2579
2580 L56:;
2581 #line 886 "type.pcc"
2582 ty_env.insert(id,mkpolyty(ty,tyvars));
2583 #line 886 "type.pcc"
2584 }
2585 } break;
2586 default: { goto L56; } break;
2587 }
2588 } else { goto L56; }
2589 } break;
2590 default: { goto L56; } break;
2591 }
2592 } else { goto L56; }
2593 }
2594 #line 887 "type.pcc"
2595 #line 887 "type.pcc"
2596
2597 }
2598 }
2599
2600 /////////////////////////////////////////////////////////////////////////////
2601 //
2602 // Method to add a new datatype to the environment.
2603 //
2604 /////////////////////////////////////////////////////////////////////////////
2605 void add_datatype( const Loc * location,
2606 Id id,
2607 TyVars tyvars,
2608 Inherits inherit,
2609 TyQual qual,
2610 Exp view_match,
2611 TermDefs terms,
2612 Decls body
2613 )
2614 { HashTable::Entry * i = ty_env.lookup(id);
2615 if (i) {
2616 Ty ty = (Ty)ty_env.value(i);
2617
2618 #line 908 "type.pcc"
2619 #line 915 "type.pcc"
2620 {
2621 Ty _V22 = deref_all(ty);
2622 if (_V22) {
2623 switch (_V22->tag__) {
2624 case a_Ty::tag_TYCONty: {
2625 if (boxed(((Ty_TYCONty *)_V22)->_1)) {
2626 switch (((Ty_TYCONty *)_V22)->_1->tag__) {
2627 case a_TyCon::tag_DATATYPEtycon: {
2628 #line 910 "type.pcc"
2629 error("%Lredefinition of datatype %s\n"
2630 "%!this is where datatype %s was previously defined\n",
2631 id, ((TyCon_DATATYPEtycon *)((Ty_TYCONty *)_V22)->_1)->location, id);
2632
2633 #line 913 "type.pcc"
2634 } break;
2635 default: {
2636 L57:;
2637 #line 915 "type.pcc"
2638 error("%Lredefinition of datatype %s\n", id);
2639 #line 915 "type.pcc"
2640 } break;
2641 }
2642 } else { goto L57; }
2643 } break;
2644 default: { goto L57; } break;
2645 }
2646 } else { goto L57; }
2647 }
2648 #line 916 "type.pcc"
2649 #line 916 "type.pcc"
2650
2651 } else {
2652 TyCon tycon =
2653 #line 918 "type.pcc"
2654 #line 918 "type.pcc"
2655 DATATYPEtycon(id, 0, 0, 0, tyvars, NOty, inherit, qual, 0, body, view_match, location, 0)
2656 #line 930 "type.pcc"
2657 #line 930 "type.pcc"
2658 ;
2659 Ty this_ty = TYCONty(tycon, tyvars_to_type_list(0,tyvars));
2660 int variants = length(terms);
2661 int arg_count = 0;
2662 int unit_count = 0;
2663 Cons * all_conses = (Cons *)mem_pool[variants * sizeof(Cons)];
2664 int units = 0;
2665 int args = 0;
2666 int optimizations = 0;
2667 int arity = length(tyvars);
2668 Id * bound_vars = (Id *)mem_pool[arity * sizeof(Id)];
2669 { int i = 0;
2670 for_each (TyVar, tv, tyvars)
2671 bound_vars[i++] = tv;
2672 }
2673
2674 { for_each(TermDef, t, terms)
2675
2676 #line 947 "type.pcc"
2677 #line 949 "type.pcc"
2678 {
2679 if (t->ty) {
2680 #line 949 "type.pcc"
2681 args++;
2682 #line 949 "type.pcc"
2683 } else {
2684 #line 948 "type.pcc"
2685 units++;
2686 #line 948 "type.pcc"
2687 }
2688 }
2689 #line 950 "type.pcc"
2690 #line 950 "type.pcc"
2691
2692 }
2693
2694 Ty poly = mkpolyty(this_ty, tyvars);
2695
2696 // compute optimizations.
2697 if (args == 1) optimizations |= OPTsubclassless | OPTtagless;
2698 if (args > 1 && args <= options.max_embedded_tags
2699 && (qual & QUALvirtual) == 0
2700 && (options.tagged_pointer || (qual & QUALtaggedpointer)))
2701 optimizations |= OPTtaggedpointer | OPTtagless;
2702 else if (args <= 1)
2703 optimizations |= OPTtagless;
2704
2705 int actual_boxed = 0;
2706 for_each(TermDef, t, terms)
2707 {
2708 #line 966 "type.pcc"
2709 #line 1034 "type.pcc"
2710 {
2711 if (
2712 #line 967 "type.pcc"
2713 (t->id == 0)
2714 #line 967 "type.pcc"
2715 ) {
2716
2717 #line 968 "type.pcc"
2718 qual |= QUALextensible;
2719 #line 968 "type.pcc"
2720 } else {
2721
2722 #line 972 "type.pcc"
2723 int tag;
2724 Pat lexeme_pat =
2725 (qual & QUALlexeme) && t->id[0] == '"'
2726 ? LITERALpat(STRINGlit(t->id)) : t->pat;
2727 Cons last_cons = find_cons(t->id);
2728 if (last_cons != NOcons) {
2729 error ("%!redefinition of constructor '%s'\n"
2730 "%!this is where '%s' was last defined.\n",
2731 t->loc(), t->id, last_cons->location, t->id);
2732 }
2733 if (t->ty == NOty) tag = unit_count++; else tag = arg_count++;
2734 if (t->print_formats !=
2735 #line 983 "type.pcc"
2736 #line 983 "type.pcc"
2737 nil_1_
2738 #line 983 "type.pcc"
2739 #line 983 "type.pcc"
2740 ) qual |= QUALprintable;
2741 Ty cons_ty = t->ty == NOty
2742 ? poly
2743 : POLYty(mkfunty(t->ty, this_ty), arity, bound_vars);
2744
2745 // Use unboxed optimization
2746 // only if we are also using the tagged pointer rep.
2747 // Make sure (1) the type is embeddable into 1 word.
2748 // (2) We are monomorphic.
2749 // (3) We are not using any inheritance.
2750 int this_opt = OPTnone;
2751 if ((optimizations & OPTtaggedpointer) &&
2752 tyvars ==
2753 #line 995 "type.pcc"
2754 #line 995 "type.pcc"
2755 nil_1_
2756 #line 995 "type.pcc"
2757 #line 995 "type.pcc"
2758 &&
2759 t->inherits ==
2760 #line 996 "type.pcc"
2761 #line 996 "type.pcc"
2762 nil_1_
2763 #line 996 "type.pcc"
2764 #line 996 "type.pcc"
2765 &&
2766 t->opt == OPTunboxed &&
2767 (qual & (QUALrewritable | QUALcollectable |
2768 QUALrelation | QUALpersistent))
2769 == 0 &&
2770 is_embeddable_ty(t->ty))
2771 this_opt = OPTunboxed;
2772
2773 Exp * view_selectors =
2774 (qual & QUALview) ?
2775 (Exp*)mem_pool.c_alloc(arity_of(t->ty) * sizeof(Exp)) : 0;
2776 Cons cons =
2777 #line 1007 "type.pcc"
2778 #line 1007 "type.pcc"
2779 ONEcons(t->id, this_ty, cons_ty, t->ty, tag, t->print_formats, t->loc(), t->inherits, t->decls, this_opt, t->qual, t->view_predicate, view_selectors, lexeme_pat, 0)
2780 #line 1021 "type.pcc"
2781 #line 1021 "type.pcc"
2782 ;
2783 all_conses[t->ty == NOty ? tag : tag + units] = cons;
2784 if (t->ty != NOty && (this_opt & OPTunboxed) == 0)
2785 actual_boxed++;
2786
2787 // update the constructor environment
2788 cons_env.insert(t->id, cons);
2789
2790 // update the token environment
2791
2792 #line 1030 "type.pcc"
2793 #line 1033 "type.pcc"
2794 {
2795 if (lexeme_pat) {
2796 switch (lexeme_pat->tag__) {
2797 case a_Pat::tag_LITERALpat: {
2798 switch (((Pat_LITERALpat *)lexeme_pat)->LITERALpat->tag__) {
2799 case a_Literal::tag_STRINGlit: {
2800 #line 1031 "type.pcc"
2801 token_env.insert(((Literal_STRINGlit *)((Pat_LITERALpat *)lexeme_pat)->LITERALpat)->STRINGlit, cons);
2802 #line 1031 "type.pcc"
2803 } break;
2804 default: {
2805 L58:; } break;
2806 }
2807 } break;
2808 default: { goto L58; } break;
2809 }
2810 } else { goto L58; }
2811 }
2812 #line 1033 "type.pcc"
2813 #line 1033 "type.pcc"
2814
2815
2816 #line 1034 "type.pcc"
2817 }
2818 }
2819 #line 1035 "type.pcc"
2820 #line 1035 "type.pcc"
2821
2822 }
2823
2824 if (actual_boxed <= 1) optimizations |= OPTsubclassless | OPTtagless;
2825
2826 if (tyvars && unit_count > 1)
2827 error("%Lmultiple unit constructors in polymorphic type %s%V"
2828 " is not supported\n",
2829 id, tyvars);
2830
2831
2832 #line 1045 "type.pcc"
2833 #line 1050 "type.pcc"
2834 {
2835 if (boxed(tycon)) {
2836 switch (tycon->tag__) {
2837 case a_TyCon::tag_DATATYPEtycon: {
2838 #line 1047 "type.pcc"
2839 ((TyCon_DATATYPEtycon *)tycon)->unit = unit_count; ((TyCon_DATATYPEtycon *)tycon)->arg = arg_count; ((TyCon_DATATYPEtycon *)tycon)->terms = all_conses;
2840 ((TyCon_DATATYPEtycon *)tycon)->polyty = poly; ((TyCon_DATATYPEtycon *)tycon)->opt = optimizations; ((TyCon_DATATYPEtycon *)tycon)->qualifiers = qual;
2841
2842 #line 1049 "type.pcc"
2843 } break;
2844 default: {
2845 L59:; } break;
2846 }
2847 } else { goto L59; }
2848 }
2849 #line 1051 "type.pcc"
2850 #line 1051 "type.pcc"
2851
2852
2853 ty_env.insert(id, poly);
2854 if (qual & QUALlexeme) update_lexeme_class(id, terms);
2855
2856 // Create new type hierarchy
2857 new DatatypeHierarchy(id,tyvars,inherit,qual,terms,body);
2858 }
2859 }
2860
2861 /////////////////////////////////////////////////////////////////////////////
2862 //
2863 // Method to refine the implementation of a datatype.
2864 //
2865 /////////////////////////////////////////////////////////////////////////////
2866 void update_datatype (Id id, TyVars tyvars, Inherits superclasses,
2867 TyQual qual, Decls decls)
2868 {
2869
2870 #line 1069 "type.pcc"
2871 #line 1080 "type.pcc"
2872 {
2873 Ty _V23 = lookup_ty(id);
2874 if (_V23) {
2875 switch (_V23->tag__) {
2876 case a_Ty::tag_TYCONty: {
2877 if (boxed(((Ty_TYCONty *)_V23)->_1)) {
2878 switch (((Ty_TYCONty *)_V23)->_1->tag__) {
2879 case a_TyCon::tag_DATATYPEtycon: {
2880 if (
2881 #line 1070 "type.pcc"
2882 (((TyCon_DATATYPEtycon *)((Ty_TYCONty *)_V23)->_1)->hierarchy != 0)
2883 #line 1070 "type.pcc"
2884 ) {
2885
2886 #line 1071 "type.pcc"
2887 if (superclasses)
2888 ((TyCon_DATATYPEtycon *)((Ty_TYCONty *)_V23)->_1)->hierarchy->inherited_classes =
2889 append(((TyCon_DATATYPEtycon *)((Ty_TYCONty *)_V23)->_1)->hierarchy->inherited_classes,superclasses);
2890 ((TyCon_DATATYPEtycon *)((Ty_TYCONty *)_V23)->_1)->hierarchy->qualifiers |= qual;
2891 ((TyCon_DATATYPEtycon *)((Ty_TYCONty *)_V23)->_1)->qualifiers |= qual;
2892 if (decls)
2893 ((TyCon_DATATYPEtycon *)((Ty_TYCONty *)_V23)->_1)->hierarchy->class_body = append(((TyCon_DATATYPEtycon *)((Ty_TYCONty *)_V23)->_1)->hierarchy->class_body,decls);
2894
2895 #line 1078 "type.pcc"
2896 } else {
2897
2898 L60:;
2899 #line 1080 "type.pcc"
2900 error ("%Ltype %s = %T is not a datatype\n",id, _V23);
2901 #line 1080 "type.pcc"
2902 }
2903 } break;
2904 default: { goto L60; } break;
2905 }
2906 } else { goto L60; }
2907 } break;
2908 default: { goto L60; } break;
2909 }
2910 } else {
2911 #line 1079 "type.pcc"
2912 /* skip */
2913 #line 1079 "type.pcc"
2914 }
2915 }
2916 #line 1081 "type.pcc"
2917 #line 1081 "type.pcc"
2918
2919 }
2920
2921 /////////////////////////////////////////////////////////////////////////////
2922 //
2923 // Method to refine the implementation of a datatype constructor.
2924 //
2925 /////////////////////////////////////////////////////////////////////////////
2926 void update_constructor
2927 (Id id, Tys ty_args, Inherits inh, PrintFormats pf, Decls decls)
2928 {
2929 #line 1091 "type.pcc"
2930 #line 1108 "type.pcc"
2931 {
2932 Cons _V24 = lookup_cons(id);
2933 if (_V24) {
2934 if (_V24->alg_ty) {
2935 switch (_V24->alg_ty->tag__) {
2936 case a_Ty::tag_TYCONty: {
2937 if (boxed(((Ty_TYCONty *)_V24->alg_ty)->_1)) {
2938 switch (((Ty_TYCONty *)_V24->alg_ty)->_1->tag__) {
2939 case a_TyCon::tag_DATATYPEtycon: {
2940 #line 1095 "type.pcc"
2941 if (pf) {
2942 if (_V24->print_formats)
2943 error("%Lconstructor %s already has print formats\n",id);
2944 else
2945 _V24->print_formats = pf;
2946 ((TyCon_DATATYPEtycon *)((Ty_TYCONty *)_V24->alg_ty)->_1)->qualifiers |= QUALprintable;
2947 }
2948 if (decls)
2949 _V24->class_def->class_body = append(_V24->class_def->class_body,decls);
2950 if (inh)
2951 _V24->class_def->inherited_classes = append(_V24->class_def->inherited_classes,
2952 inh);
2953
2954 #line 1107 "type.pcc"
2955 } break;
2956 default: {
2957 L61:;
2958 #line 1108 "type.pcc"
2959 /* skip */
2960 #line 1108 "type.pcc"
2961 } break;
2962 }
2963 } else { goto L61; }
2964 } break;
2965 default: { goto L61; } break;
2966 }
2967 } else { goto L61; }
2968 } else { goto L61; }
2969 }
2970 #line 1109 "type.pcc"
2971 #line 1109 "type.pcc"
2972
2973 }
2974
2975 /////////////////////////////////////////////////////////////////////////////
2976 //
2977 // Hashing function on types
2978 //
2979 /////////////////////////////////////////////////////////////////////////////
2980 unsigned int ty_hash(HashTable::Key k)
2981 { Ty ty = (Ty)k;
2982
2983 #line 1119 "type.pcc"
2984 #line 1144 "type.pcc"
2985 {
2986 Ty _V25 = deref_all(ty);
2987 if (_V25) {
2988 switch (_V25->tag__) {
2989 case a_Ty::tag_VARty: {
2990 #line 1121 "type.pcc"
2991 return (unsigned int)_V25;
2992 #line 1121 "type.pcc"
2993 } break;
2994 case a_Ty::tag_TYCONty: {
2995 #line 1123 "type.pcc"
2996 unsigned int h;
2997
2998 #line 1124 "type.pcc"
2999 #line 1139 "type.pcc"
3000 {
3001 TyCon _V26 = ((Ty_TYCONty *)_V25)->_1;
3002 if (boxed(_V26)) {
3003 switch (_V26->tag__) {
3004 case a_TyCon::tag_IDtycon: {
3005 #line 1132 "type.pcc"
3006 h = string_hash(((TyCon_IDtycon *)_V26)->IDtycon) + 89;
3007 #line 1132 "type.pcc"
3008 } break;
3009 case a_TyCon::tag_RECORDtycon: {
3010 #line 1128 "type.pcc"
3011 h = 129;
3012 #line 1128 "type.pcc"
3013 } break;
3014 case a_TyCon::tag_ARRAYtycon: {
3015 #line 1131 "type.pcc"
3016 h = 569;
3017 #line 1131 "type.pcc"
3018 } break;
3019 case a_TyCon::tag_BITFIELDtycon: {
3020 #line 1134 "type.pcc"
3021 h = 733 + ((TyCon_BITFIELDtycon *)_V26)->width;
3022 #line 1134 "type.pcc"
3023 } break;
3024 case a_TyCon::tag_DATATYPEtycon: {
3025 #line 1133 "type.pcc"
3026 h = string_hash(((TyCon_DATATYPEtycon *)_V26)->id) + 431;
3027 #line 1133 "type.pcc"
3028 } break;
3029 case a_TyCon::tag_COLtycon: {
3030 #line 1136 "type.pcc"
3031 h = string_hash(((TyCon_COLtycon *)_V26)->COLtycon->name) + 1345;
3032 #line 1136 "type.pcc"
3033 } break;
3034 case a_TyCon::tag_GRAPHtycon: {
3035 #line 1137 "type.pcc"
3036 h = (int)((TyCon_GRAPHtycon *)_V26)->GRAPHtycon;
3037 #line 1137 "type.pcc"
3038 } break;
3039 case a_TyCon::tag_NODEtycon: {
3040 #line 1138 "type.pcc"
3041 h = (int)((TyCon_NODEtycon *)_V26)->NODEtycon;
3042 #line 1138 "type.pcc"
3043 } break;
3044 default: {
3045 #line 1139 "type.pcc"
3046 h = (int)((TyCon_EDGEtycon *)_V26)->EDGEtycon;
3047 #line 1139 "type.pcc"
3048 } break;
3049 }
3050 } else {
3051 switch ((int)_V26) {
3052 case ((int)POINTERtycon): {
3053 #line 1125 "type.pcc"
3054 h = 37;
3055 #line 1125 "type.pcc"
3056 } break;
3057 case ((int)REFtycon): {
3058 #line 1126 "type.pcc"
3059 h = 47;
3060 #line 1126 "type.pcc"
3061 } break;
3062 case ((int)TUPLEtycon): {
3063 #line 1129 "type.pcc"
3064 h = 173;
3065 #line 1129 "type.pcc"
3066 } break;
3067 case ((int)EXTUPLEtycon): {
3068 #line 1130 "type.pcc"
3069 h = 467;
3070 #line 1130 "type.pcc"
3071 } break;
3072 case ((int)FUNtycon): {
3073 #line 1127 "type.pcc"
3074 h = 79;
3075 #line 1127 "type.pcc"
3076 } break;
3077 default: {
3078 #line 1135 "type.pcc"
3079 h = 1235;
3080 #line 1135 "type.pcc"
3081 } break;
3082 }
3083 }
3084 }
3085 #line 1140 "type.pcc"
3086 #line 1140 "type.pcc"
3087
3088 return h + tys_hash(((Ty_TYCONty *)_V25)->_2);
3089
3090 #line 1142 "type.pcc"
3091 } break;
3092 case a_Ty::tag_NESTEDty: {
3093 #line 1143 "type.pcc"
3094 return ty_hash(((Ty_NESTEDty *)_V25)->_1) + ty_hash(((Ty_NESTEDty *)_V25)->_2);
3095 #line 1143 "type.pcc"
3096 } break;
3097 default: {
3098 #line 1144 "type.pcc"
3099 return 0;
3100 #line 1144 "type.pcc"
3101 } break;
3102 }
3103 } else {
3104 #line 1120 "type.pcc"
3105 return 0;
3106 #line 1120 "type.pcc"
3107 }
3108 }
3109 #line 1145 "type.pcc"
3110 #line 1145 "type.pcc"
3111
3112 }
3113
3114 /////////////////////////////////////////////////////////////////////////////
3115 //
3116 // Hashing function on type list
3117 //
3118 /////////////////////////////////////////////////////////////////////////////
3119 unsigned int tys_hash(HashTable::Key k)
3120 { Tys tys = (Tys)k;
3121 unsigned int h = 0;
3122 for_each (Ty, t, tys) h += ty_hash(t);
3123 return h;
3124 }
3125
3126 /////////////////////////////////////////////////////////////////////////////
3127 //
3128 // Equality function on types
3129 //
3130 /////////////////////////////////////////////////////////////////////////////
3131 Bool ty_equal(HashTable::Key a, HashTable::Key b)
3132 { Ty u = (Ty)a, v = (Ty)b;
3133
3134 #line 1167 "type.pcc"
3135 #line 1194 "type.pcc"
3136 {
3137 Ty _V27 = deref_all(u);
3138 Ty _V28 = deref_all(v);
3139 if (
3140 #line 1168 "type.pcc"
3141 (_V27 == _V28)
3142 #line 1168 "type.pcc"
3143 ) {
3144
3145 #line 1168 "type.pcc"
3146 return true;
3147 #line 1168 "type.pcc"
3148 } else {
3149
3150 if (_V27) {
3151 switch (_V27->tag__) {
3152 case a_Ty::tag_VARty: {
3153 if (_V28) {
3154 switch (_V28->tag__) {
3155 case a_Ty::tag_VARty: {
3156 #line 1169 "type.pcc"
3157 return _V27 == _V28;
3158 #line 1169 "type.pcc"
3159 } break;
3160 default: {
3161 L62:;
3162 #line 1194 "type.pcc"
3163 return false;
3164 #line 1194 "type.pcc"
3165 } break;
3166 }
3167 } else { goto L62; }
3168 } break;
3169 case a_Ty::tag_TYCONty: {
3170 if (_V28) {
3171 switch (_V28->tag__) {
3172 case a_Ty::tag_TYCONty: {
3173 if (boxed(((Ty_TYCONty *)_V27)->_1)) {
3174 switch (((Ty_TYCONty *)_V27)->_1->tag__) {
3175 case a_TyCon::tag_RECORDtycon: {
3176 if (_V28) {
3177 switch (_V28->tag__) {
3178 case a_Ty::tag_TYCONty: {
3179 if (boxed(((Ty_TYCONty *)_V28)->_1)) {
3180 switch (((Ty_TYCONty *)_V28)->_1->tag__) {
3181 case a_TyCon::tag_RECORDtycon: {
3182 L63:;
3183 #line 1174 "type.pcc"
3184 Ids i, j; Tys t, u;
3185 if (length(((Ty_TYCONty *)_V27)->_2) != length(((Ty_TYCONty *)_V28)->_2)) return false;
3186 for (i = ((TyCon_RECORDtycon *)((Ty_TYCONty *)_V27)->_1)->_1, t = ((Ty_TYCONty *)_V27)->_2; i; i = i->_2, t = t->_2)
3187 { Bool found = false;
3188 for (j = ((TyCon_RECORDtycon *)((Ty_TYCONty *)_V28)->_1)->_1, u = ((Ty_TYCONty *)_V28)->_2; j; j = j->_2, u = u->_2)
3189 { if (i->_1 == j->_1) {
3190 if (! ty_equal(t->_1, u->_2)) return false;
3191 found = true; break;
3192 }
3193 }
3194 if (! found) return false;
3195 }
3196 return true;
3197
3198 #line 1187 "type.pcc"
3199 } break;
3200 default: {
3201 L64:;
3202 #line 1189 "type.pcc"
3203 if (! unify(((Ty_TYCONty *)_V27)->_1,((Ty_TYCONty *)_V28)->_1)) return false;
3204 return tys_equal(((Ty_TYCONty *)_V27)->_2,((Ty_TYCONty *)_V28)->_2);
3205
3206 #line 1191 "type.pcc"
3207 } break;
3208 }
3209 } else { goto L64; }
3210 } break;
3211 default: { goto L64; } break;
3212 }
3213 } else { goto L64; }
3214 } break;
3215 case a_TyCon::tag_GRAPHtycon: {
3216 if (_V28) {
3217 switch (_V28->tag__) {
3218 case a_Ty::tag_TYCONty: {
3219 if (boxed(((Ty_TYCONty *)_V28)->_1)) {
3220 switch (((Ty_TYCONty *)_V28)->_1->tag__) {
3221 case a_TyCon::tag_GRAPHtycon: {
3222 L65:;
3223 #line 1170 "type.pcc"
3224 return ((TyCon_GRAPHtycon *)((Ty_TYCONty *)_V27)->_1)->GRAPHtycon == ((TyCon_GRAPHtycon *)((Ty_TYCONty *)_V28)->_1)->GRAPHtycon;
3225 #line 1170 "type.pcc"
3226 } break;
3227 default: { goto L64; } break;
3228 }
3229 } else { goto L64; }
3230 } break;
3231 default: { goto L64; } break;
3232 }
3233 } else { goto L64; }
3234 } break;
3235 case a_TyCon::tag_NODEtycon: {
3236 if (_V28) {
3237 switch (_V28->tag__) {
3238 case a_Ty::tag_TYCONty: {
3239 if (boxed(((Ty_TYCONty *)_V28)->_1)) {
3240 switch (((Ty_TYCONty *)_V28)->_1->tag__) {
3241 case a_TyCon::tag_NODEtycon: {
3242 L66:;
3243 #line 1171 "type.pcc"
3244 return ((TyCon_NODEtycon *)((Ty_TYCONty *)_V27)->_1)->NODEtycon == ((TyCon_NODEtycon *)((Ty_TYCONty *)_V28)->_1)->NODEtycon;
3245 #line 1171 "type.pcc"
3246 } break;
3247 default: { goto L64; } break;
3248 }
3249 } else { goto L64; }
3250 } break;
3251 default: { goto L64; } break;
3252 }
3253 } else { goto L64; }
3254 } break;
3255 case a_TyCon::tag_EDGEtycon: {
3256 if (_V28) {
3257 switch (_V28->tag__) {
3258 case a_Ty::tag_TYCONty: {
3259 if (boxed(((Ty_TYCONty *)_V28)->_1)) {
3260 switch (((Ty_TYCONty *)_V28)->_1->tag__) {
3261 case a_TyCon::tag_EDGEtycon: {
3262 L67:;
3263 #line 1172 "type.pcc"
3264 return ((TyCon_EDGEtycon *)((Ty_TYCONty *)_V27)->_1)->EDGEtycon == ((TyCon_EDGEtycon *)((Ty_TYCONty *)_V28)->_1)->EDGEtycon;
3265 #line 1172 "type.pcc"
3266 } break;
3267 default: { goto L64; } break;
3268 }
3269 } else { goto L64; }
3270 } break;
3271 default: { goto L64; } break;
3272 }
3273 } else { goto L64; }
3274 } break;
3275 default: { goto L64; } break;
3276 }
3277 } else { goto L64; }
3278 } break;
3279 default: {
3280 L68:;
3281 if (boxed(((Ty_TYCONty *)_V27)->_1)) {
3282 switch (((Ty_TYCONty *)_V27)->_1->tag__) {
3283 case a_TyCon::tag_RECORDtycon: {
3284 L69:;
3285 if (_V28) {
3286 switch (_V28->tag__) {
3287 case a_Ty::tag_TYCONty: {
3288 L70:;
3289 if (boxed(((Ty_TYCONty *)_V28)->_1)) {
3290 switch (((Ty_TYCONty *)_V28)->_1->tag__) {
3291 case a_TyCon::tag_RECORDtycon: { goto L63; } break;
3292 default: { goto L62; } break;
3293 }
3294 } else { goto L62; }
3295 } break;
3296 default: { goto L62; } break;
3297 }
3298 } else { goto L62; }
3299 } break;
3300 case a_TyCon::tag_GRAPHtycon: {
3301 L71:;
3302 if (_V28) {
3303 switch (_V28->tag__) {
3304 case a_Ty::tag_TYCONty: {
3305 L72:;
3306 if (boxed(((Ty_TYCONty *)_V28)->_1)) {
3307 switch (((Ty_TYCONty *)_V28)->_1->tag__) {
3308 case a_TyCon::tag_GRAPHtycon: { goto L65; } break;
3309 default: { goto L62; } break;
3310 }
3311 } else { goto L62; }
3312 } break;
3313 default: { goto L62; } break;
3314 }
3315 } else { goto L62; }
3316 } break;
3317 case a_TyCon::tag_NODEtycon: {
3318 L73:;
3319 if (_V28) {
3320 switch (_V28->tag__) {
3321 case a_Ty::tag_TYCONty: {
3322 L74:;
3323 if (boxed(((Ty_TYCONty *)_V28)->_1)) {
3324 switch (((Ty_TYCONty *)_V28)->_1->tag__) {
3325 case a_TyCon::tag_NODEtycon: { goto L66; } break;
3326 default: { goto L62; } break;
3327 }
3328 } else { goto L62; }
3329 } break;
3330 default: { goto L62; } break;
3331 }
3332 } else { goto L62; }
3333 } break;
3334 case a_TyCon::tag_EDGEtycon: {
3335 L75:;
3336 if (_V28) {
3337 switch (_V28->tag__) {
3338 case a_Ty::tag_TYCONty: {
3339 L76:;
3340 if (boxed(((Ty_TYCONty *)_V28)->_1)) {
3341 switch (((Ty_TYCONty *)_V28)->_1->tag__) {
3342 case a_TyCon::tag_EDGEtycon: { goto L67; } break;
3343 default: { goto L62; } break;
3344 }
3345 } else { goto L62; }
3346 } break;
3347 default: { goto L62; } break;
3348 }
3349 } else { goto L62; }
3350 } break;
3351 default: { goto L62; } break;
3352 }
3353 } else { goto L62; }
3354 } break;
3355 }
3356 } else { goto L68; }
3357 } break;
3358 case a_Ty::tag_NESTEDty: {
3359 if (_V28) {
3360 switch (_V28->tag__) {
3361 case a_Ty::tag_NESTEDty: {
3362 #line 1193 "type.pcc"
3363 return ty_equal(((Ty_NESTEDty *)_V27)->_1,((Ty_NESTEDty *)_V28)->_1) && ty_equal(((Ty_NESTEDty *)_V27)->_2,((Ty_NESTEDty *)_V28)->_2);
3364 #line 1193 "type.pcc"
3365 } break;
3366 default: { goto L62; } break;
3367 }
3368 } else { goto L62; }
3369 } break;
3370 default: { goto L62; } break;
3371 }
3372 } else { goto L62; }
3373 }
3374 }
3375 #line 1195 "type.pcc"
3376 #line 1195 "type.pcc"
3377
3378 }
3379
3380 /////////////////////////////////////////////////////////////////////////////
3381 //
3382 // Equality function on type lists
3383 //
3384 /////////////////////////////////////////////////////////////////////////////
3385 Bool tys_equal(HashTable::Key a, HashTable::Key b)
3386 { Tys u = (Tys)a, v = (Tys)b;
3387
3388 #line 1205 "type.pcc"
3389 #line 1207 "type.pcc"
3390 {
3391 for (;;) {
3392 if (u) {
3393 if (v) {
3394 #line 1207 "type.pcc"
3395 if (!ty_equal(u->_1,v->_1)) return false; u = u->_2; v = v->_2;
3396 #line 1207 "type.pcc"
3397 } else { goto L77; }
3398 } else { goto L77; }
3399 }
3400 L77:;
3401 }
3402 #line 1208 "type.pcc"
3403 #line 1208 "type.pcc"
3404
3405 return u ==
3406 #line 1209 "type.pcc"
3407 #line 1209 "type.pcc"
3408 nil_1_
3409 #line 1209 "type.pcc"
3410 #line 1209 "type.pcc"
3411 && v ==
3412 #line 1209 "type.pcc"
3413 #line 1209 "type.pcc"
3414 nil_1_
3415 #line 1209 "type.pcc"
3416 #line 1209 "type.pcc"
3417 ;
3418 }
3419
3420 /////////////////////////////////////////////////////////////////////////////
3421 //
3422 // Equality on qualified identifiers.
3423 //
3424 /////////////////////////////////////////////////////////////////////////////
3425 #line 1217 "type.pcc"
3426 #line 1221 "type.pcc"
3427 Bool qualid_equal (QualId x_1, QualId x_2);
3428 Bool qualid_equal (QualId x_1, QualId x_2)
3429 {
3430 if (untagp(x_1)) {
3431
3432 if (untagp(x_2)) {
3433
3434 #line 1217 "type.pcc"
3435 return ((QualId_SIMPLEid *)derefp(x_1))->SIMPLEid == ((QualId_SIMPLEid *)derefp(x_2))->SIMPLEid;
3436 #line 1217 "type.pcc"
3437 } else {
3438
3439 L78:;
3440 #line 1220 "type.pcc"
3441 return false;
3442 #line 1220 "type.pcc"
3443 }
3444 } else {
3445
3446 if (untagp(x_2)) {
3447 goto L78; } else {
3448
3449 #line 1219 "type.pcc"
3450 return ty_equal(((QualId_NESTEDid *)x_1)->_1,((QualId_NESTEDid *)x_2)->_1) && qualid_equal(((QualId_NESTEDid *)x_1)->_2,((QualId_NESTEDid *)x_2)->_2);
3451 #line 1219 "type.pcc"
3452 }
3453 }
3454 }
3455 #line 1221 "type.pcc"
3456 #line 1221 "type.pcc"
3457
3458 #line 1222 "type.pcc"
3459 /*
3460 ------------------------------- Statistics -------------------------------
3461 Merge matching rules = yes
3462 Number of DFA nodes merged = 2865
3463 Number of ifs generated = 162
3464 Number of switches generated = 116
3465 Number of labels = 71
3466 Number of gotos = 198
3467 Adaptive matching = enabled
3468 Fast string matching = disabled
3469 Inline downcasts = enabled
3470 --------------------------------------------------------------------------
3471 */
Prop: a C++ based pattern matching language