1 /* types and subtypes
2
3 Copyright (C) 1994-1997 University of Dortmund
4 Department of Electrical Engineering, AG SIV
5
6 VAUL is free software; you can redistribute it and/or modify it
7 under the terms of the GNU Library General Public License as
8 published by the Free Software Foundation; either version 2 of the
9 License, or (at your option) any later version.
10
11 VAUL is distributed in the hope that it will be useful, but WITHOUT
12 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
13 or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General
14 Public License for more details.
15
16 You should have received a copy of the GNU Library General Public
17 License along with VAUL; see the file COPYING.LIB. If not, write
18 to the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
19 Boston, MA 02111-1307 USA.
20
21
22 */
23
24 #include <freehdl/vaul-parser.h>
25 #include <freehdl/vaul-chunk.h>
26 #include <freehdl/vaul-dunit.h>
27 #include <freehdl/vaul-util.h>
28
29 #include <stdio.h>
30 #include <stdlib.h>
31 #include <assert.h>
32
33 #define psr vaul_parser
34
35 struct resolution_filter_closure {
36 pIIR_Type base;
37 };
38
39 static int
resolution_filter(pIIR_Declaration d,void * closure)40 resolution_filter (pIIR_Declaration d, void *closure)
41 {
42 resolution_filter_closure *rfc = (resolution_filter_closure *)closure;
43
44 if (!d->is(IR_FUNCTION_DECLARATION))
45 return -1;
46
47 pIIR_FunctionDeclaration f = pIIR_FunctionDeclaration(d);
48 if (!f->pure)
49 return -1;
50 if (vaul_get_base (f->return_type) != rfc->base)
51 return -1;
52 if (f->interface_declarations == NULL
53 || f->interface_declarations->rest != NULL)
54 return -1;
55
56 pIIR_InterfaceDeclaration p = f->interface_declarations->first;
57 if (!p->is(IR_CONSTANT_INTERFACE_DECLARATION) || p->mode != IR_IN_MODE)
58 return -1;
59 if (!p->subtype->is(IR_ARRAY_TYPE))
60 return -1;
61
62 pIIR_ArrayType pt = pIIR_ArrayType (p->subtype);
63 if (pt->index_types == NULL || pt->index_types->rest != NULL)
64 return -1;
65 if (vaul_get_base (pt->element_type) != rfc->base)
66 return -1;
67
68 return 0;
69 }
70
71 pIIR_FunctionDeclaration
find_resolution_function(pVAUL_Name res_name,pIIR_Type type)72 psr::find_resolution_function (pVAUL_Name res_name, pIIR_Type type)
73 {
74 pIIR_FunctionDeclaration res_func = NULL;
75
76 if (res_name)
77 {
78 vaul_decl_set ds(this);
79 find_decls (ds, res_name);
80 resolution_filter_closure rfc = { type->base };
81 ds.filter (resolution_filter, &rfc);
82 ds.invalidate_pot_invalids ();
83 res_func = pIIR_FunctionDeclaration (ds.single_decl (false));
84 if (res_func == NULL)
85 {
86 error ("%:no match for resolution function %n, candidates are",
87 res_name, res_name);
88 ds.show(false);
89 }
90 assert (!res_func || res_func->is(IR_FUNCTION_DECLARATION));
91 }
92
93 return res_func;
94 }
95
96 pIIR_Type
build_ArraySubtype(pVAUL_Name res_name,pVAUL_Name type_mark,pIIR_TypeList constraint)97 psr::build_ArraySubtype (pVAUL_Name res_name,
98 pVAUL_Name type_mark,
99 pIIR_TypeList constraint)
100 {
101 pIIR_Type base = get_type (type_mark);
102 if (base == NULL)
103 return NULL;
104
105 pIIR_FunctionDeclaration res_func =
106 find_resolution_function (res_name, base);
107
108 if(constraint)
109 constraint = build_IndexConstraint (constraint, base);
110
111 // XXX - do some checks here, like constraints on
112 // access/record/file types
113
114 if (constraint == NULL && res_func == NULL)
115 return base;
116
117 pIIR_ArraySubtype subtype =
118 mIIR_ArraySubtype (type_mark->pos, base->base, base, res_func,
119 constraint);
120
121 return subtype;
122 }
123
124 pIIR_Type
build_ScalarSubtype(pVAUL_Name res_name,pVAUL_Name type_mark,pIIR_Range range)125 psr::build_ScalarSubtype (pVAUL_Name res_name,
126 pVAUL_Name type_mark,
127 pIIR_Range range)
128 {
129 pIIR_Type base = get_type (type_mark);
130 if (base == NULL)
131 return NULL;
132
133 pIIR_FunctionDeclaration res_func =
134 find_resolution_function (res_name, base);
135
136 if (range)
137 {
138 if (range->is(IR_EXPLICIT_RANGE))
139 {
140 pIIR_ExplicitRange r = pIIR_ExplicitRange(range);
141 overload_resolution(r->left, base);
142 overload_resolution(r->right, base);
143 }
144 else if (range->is(IR_ARRAY_RANGE))
145 {
146 pIIR_Type t = pIIR_ArrayRange(range)->type;
147 if (t->base != base)
148 error ("%:%n is not a base type of %n", range, t, base);
149 }
150 else
151 assert (false);
152 }
153
154 // XXX - do some checks here, like constraints on
155 // access/record/file types
156
157 if (range == NULL && res_func == NULL)
158 return base;
159 return mIIR_ScalarSubtype (type_mark->pos, base->base, base,
160 res_func, range);
161 }
162
163 pIIR_Type
build_Subtype(pVAUL_Name res_name,pVAUL_Name type_mark,pIIR_TypeList opt_constraint)164 psr::build_Subtype (pVAUL_Name res_name,
165 pVAUL_Name type_mark,
166 pIIR_TypeList opt_constraint)
167 {
168 // When we have a constraint, build a ArraySubtype
169 //
170 if (opt_constraint)
171 return build_ArraySubtype (res_name, type_mark, opt_constraint);
172
173 // Build a ScalarSubtype when the type_mark denotes a scalar type; a
174 // ArraySubtype when it is an array type; else build a unqualified
175 // subtype.
176
177 pIIR_Type base = get_type (type_mark);
178 if (base == NULL)
179 return NULL;
180
181 if (base->is(IR_SCALAR_TYPE) || base->is(IR_SCALAR_SUBTYPE))
182 return build_ScalarSubtype (res_name, type_mark, NULL);
183 if (base->is(IR_ARRAY_TYPE) || base->is(IR_ARRAY_SUBTYPE))
184 return build_ArraySubtype (res_name, type_mark, NULL);
185
186 pIIR_FunctionDeclaration res_func =
187 find_resolution_function (res_name, base);
188
189 if (res_func)
190 {
191 if (base->is(IR_RECORD_TYPE) || base->is(IR_RECORD_SUBTYPE))
192 return mIIR_RecordSubtype (type_mark->pos,
193 base->base,
194 base,
195 res_func);
196 else
197 {
198 info ("xxx - plain subtype of %s", base->kind_name());
199 return mIIR_Subtype (type_mark->pos,
200 base->base,
201 base,
202 res_func);
203 }
204 }
205
206 return base;
207 }
208
209 pIIR_Range
get_scalar_type_range(pIIR_Type type)210 psr::get_scalar_type_range (pIIR_Type type)
211 {
212 if (type->is(IR_SCALAR_SUBTYPE))
213 return pIIR_ScalarSubtype (type)->range;
214 else if (type->is(IR_ENUMERATION_TYPE))
215 {
216 pIIR_EnumerationType et = pIIR_EnumerationType (type);
217 pIIR_EnumerationLiteral left = et->enumeration_literals->first;
218 pIIR_EnumerationLiteral right;
219 for (pIIR_EnumerationLiteralList lits = et->enumeration_literals;
220 lits; lits = lits->rest)
221 right = lits->first;
222 return mIIR_ExplicitRange (type->pos,
223 mIIR_EnumLiteralReference (type->pos,
224 type, left),
225 mIIR_EnumLiteralReference (type->pos,
226 type, right),
227 IR_DIRECTION_UP);
228 }
229 else
230 {
231 info ("XXX - no range for %n", type);
232 return NULL;
233 }
234 }
235
236 pIIR_Type
build_EnumerationType(int pos,pIIR_EnumerationLiteralList lits)237 psr::build_EnumerationType (int pos, pIIR_EnumerationLiteralList lits)
238 {
239 pIIR_EnumerationType t = mIIR_EnumerationType (pos, lits);
240 int enum_pos_counter = 0;
241
242 for (pIIR_EnumerationLiteralList el = lits; el; el = el->rest)
243 {
244 el->first->subtype = t;
245 el->first->enum_pos = enum_pos_counter++;
246 }
247
248 return t;
249 }
250
251 pIIR_TypeList
build_IndexConstraint(pIIR_TypeList pre,pIIR_Type immediate_base)252 psr::build_IndexConstraint (pIIR_TypeList pre,
253 pIIR_Type immediate_base)
254 {
255 pIIR_Type base = immediate_base->base;
256
257 if (!base->is(IR_ARRAY_TYPE))
258 {
259 error ("%:only array types can have index constraints", pre);
260 return NULL;
261 }
262
263 pIIR_TypeList itypes = pIIR_ArrayType(base)->index_types;
264 pIIR_TypeList pcons = pre;
265 pIIR_TypeList cons = NULL, *ctail = &cons;
266
267 while (pcons && itypes)
268 {
269 assert (pcons->first->is(VAUL_PRE_INDEX_CONSTRAINT));
270 pVAUL_PreIndexConstraint pic = pVAUL_PreIndexConstraint(pcons->first);
271 if (itypes->first == NULL)
272 return NULL;
273
274 pIIR_Type type = NULL;
275
276 if (pic->is(VAUL_PRE_INDEX_RANGE_CONSTRAINT))
277 {
278 if (pIIR_Range r = pVAUL_PreIndexRangeConstraint(pic)->range)
279 {
280 if (r->is(IR_EXPLICIT_RANGE))
281 {
282 pIIR_ExplicitRange er = pIIR_ExplicitRange(r);
283 if (pIIR_Type itype = find_index_range_type (er))
284 {
285 overload_resolution(er->left, itype);
286 overload_resolution(er->right, itype);
287 }
288 }
289 type = mIIR_ScalarSubtype (pic->pos,
290 itypes->first->base,
291 itypes->first,
292 NULL,
293 r);
294 }
295 }
296 else if (pic->is(VAUL_PRE_INDEX_SUBTYPE_CONSTRAINT))
297 type = pVAUL_PreIndexSubtypeConstraint(pic)->type;
298 else
299 vaul_fatal ("build_IndexConstraint confused.\n");
300
301 if (type && itypes->first && type->base != itypes->first->base)
302 error ("%:constraint type (%n) does not match index type (%n)",
303 pre, type->base, itypes->first->base);
304
305 *ctail = mIIR_TypeList (pcons->pos, type, *ctail);
306 ctail = &(*ctail)->rest;
307 itypes = itypes->rest;
308 pcons = pcons->rest;
309 }
310
311 if (pcons)
312 error ("%:too many index constraints for %n", pre, immediate_base);
313 else if (itypes)
314 error ("%:too few index constraints for %n", pre, immediate_base);
315 return cons;
316 }
317
318 pIIR_Type
find_index_range_type(pIIR_ExplicitRange r)319 psr::find_index_range_type (pIIR_ExplicitRange r)
320 {
321 pIIR_Type_vector &left_types = *ambg_expr_types(r->left);
322 pIIR_Type_vector &right_types = *ambg_expr_types(r->right);
323
324 if (left_types.size() == 0 || right_types.size() == 0)
325 return NULL;
326
327 pIIR_Type_vector types;
328
329 for (int i = 0; i < left_types.size(); i++)
330 {
331 assert(left_types[i]);
332 pIIR_Type t = left_types[i];
333 if (!is_discrete_type(t->base))
334 {
335 // info ("%:%n is not discrete", t->base, t->base);
336 continue;
337 }
338 for (int j = 0; j < right_types.size(); j++)
339 {
340 assert (right_types[j]);
341 pIIR_Type tt = right_types[j];
342 if(!is_discrete_type(vaul_get_base(tt)))
343 {
344 info ("%:%n is not discrete", t->base, t->base);
345 continue;
346 }
347 if(t == std->universal_integer)
348 t = tt;
349 else if(tt == std->universal_integer)
350 tt = t;
351 if(vaul_get_base(t) == vaul_get_base(tt)) {
352 if(t == std->universal_integer)
353 {
354 // Don't look any further when universal integer is
355 // possible. Universal integers are coerced into
356 // std.standard.integer. LRM 3.2.1.1.
357
358 delete &left_types;
359 delete &right_types;
360 return std->predef_INTEGER;
361 }
362
363 if(try_overload_resolution(r->left, t, IR_INVALID)
364 && try_overload_resolution(r->right, t, IR_INVALID)) {
365 bool already_inserted = false;
366 for(int k = 0; k < types.size(); k++)
367 if(vaul_get_base(types[k]) == vaul_get_base(t)) {
368 // info("+++ - found %n twice", t);
369 already_inserted = true;
370 break;
371 }
372 if(!already_inserted)
373 types.add(t);
374 }
375 #if 0
376 else
377 info ("%:can't coerce %n,%n to %n", t, r->left, r->right, t);
378 #endif
379 }
380 }
381 }
382
383 if(types.size() == 0) {
384 error("%:index bounds must be discrete and of the same type", r);
385 if(left_types.size() > 0) {
386 info("left bound could be:");
387 for(int i = 0; i < left_types.size(); i++)
388 info("%: %n", left_types[i], left_types[i]);
389 } else
390 info("no left types");
391 if(right_types.size() > 0) {
392 info("right bound could be:");
393 for(int i = 0; i < right_types.size(); i++)
394 info("%: %n", right_types[i], right_types[i]);
395 } else
396 info("no right types");
397 } else if(types.size() != 1) {
398 error("%:type of index bounds is ambigous, it could be:", r);
399 for(int i = 0; i < types.size(); i++)
400 info("%: %n (%s)", types[i], types[i], types[i]->kind_name());
401 }
402
403 delete &left_types;
404 delete &right_types;
405
406 return types.size() == 1? types[0] : NULL;
407 }
408
409
410 pIIR_ScalarSubtype
build_SubType_def(int pos,pIIR_Range r,pIIR_Type base)411 psr::build_SubType_def (int pos, pIIR_Range r, pIIR_Type base)
412 {
413 if (r == NULL)
414 return NULL;
415
416 if (base == NULL)
417 {
418 if (r->is(IR_EXPLICIT_RANGE))
419 {
420 pIIR_ExplicitRange er = pIIR_ExplicitRange(r);
421 if (try_overload_resolution (er->left, NULL,
422 IR_INTEGER_TYPE)
423 && try_overload_resolution (er->right, NULL,
424 IR_INTEGER_TYPE))
425 {
426 base = mIIR_IntegerType (pos);
427 }
428 else if (try_overload_resolution (er->left, NULL,
429 IR_FLOATING_TYPE)
430 && try_overload_resolution (er->right, NULL,
431 IR_FLOATING_TYPE))
432 {
433 base = mIIR_FloatingType (pos);
434 }
435 else
436 {
437 error ("%!range bounds must be both either integer"
438 " or real values", lex, pos);
439 #if 0
440 info("%!they can be:", lex, pos);
441 pIIR_Type_vector &types = *ambg_expr_types(er->first);
442 for (int i = 0; i < types.size(); i++)
443 info ("%: %n", types[i], types[i]);
444 pIIR_Type_vector &types2 = *ambg_expr_types(er->last);
445 info ("and");
446 for (int i = 0; i < types2.size(); i++)
447 info ("%: %n", types2[i], types2[i]);
448 #endif
449 return NULL;
450 }
451 }
452 else if (r->is(IR_ARRAY_RANGE))
453 {
454 info ("XXX - no array ranges in type definition");
455 return NULL;
456 }
457 else
458 assert (false);
459 }
460
461 IR_Kind base_k = base->kind();
462 if (base_k == IR_PHYSICAL_TYPE)
463 base_k = IR_INTEGER_TYPE;
464 assert (r->is(IR_EXPLICIT_RANGE)); // for now...
465 overload_resolution (pIIR_ExplicitRange(r)->left, base_k);
466 overload_resolution (pIIR_ExplicitRange(r)->right, base_k);
467
468 return mIIR_ScalarSubtype (pos, base->base, base, NULL, r);
469 }
470
471 pIIR_Type
get_type(pVAUL_Name mark)472 psr::get_type (pVAUL_Name mark)
473 {
474 pIIR_TypeDeclaration d =
475 pIIR_TypeDeclaration(find_single_decl (mark, IR_TYPE_DECLARATION, "type"));
476 if (d && d->type)
477 {
478 if (d->type->is(VAUL_INCOMPLETE_TYPE))
479 error ("%:type %n is incomplete", mark, mark);
480 else
481 return d->type;
482 }
483 return NULL;
484 }
485
486 void
add_PredefOp(pIIR_PosInfo pos,pIIR_Type ret,pIIR_TextLiteral sym,pIIR_Type left,pIIR_Type right)487 psr::add_PredefOp (pIIR_PosInfo pos, pIIR_Type ret,
488 pIIR_TextLiteral sym, pIIR_Type left,
489 pIIR_Type right)
490 {
491 pIIR_InterfaceList interf =
492 mIIR_InterfaceList (pos,
493 mIIR_ConstantInterfaceDeclaration (pos, NULL,
494 left, NULL,
495 IR_IN_MODE,
496 false),
497 NULL);
498 if (right)
499 interf->rest =
500 mIIR_InterfaceList (pos,
501 mIIR_ConstantInterfaceDeclaration (pos, NULL,
502 right, NULL,
503 IR_IN_MODE,
504 false),
505 NULL);
506
507 add_decl (mIIR_PredefinedFunctionDeclaration (pos, sym, interf, true, ret));
508 }
509
510 pIIR_Type
is_one_dim_array(pIIR_Type t)511 psr::is_one_dim_array (pIIR_Type t)
512 {
513 if (!t->is(IR_ARRAY_TYPE))
514 return NULL;
515 pIIR_ArrayType at = pIIR_ArrayType(t);
516 if (!at->index_types || at->index_types->rest)
517 return NULL;
518 return at->element_type;
519 }
520
521 bool
is_one_dim_logical_array(pIIR_Type t)522 psr::is_one_dim_logical_array (pIIR_Type t)
523 {
524 pIIR_Type et = is_one_dim_array (t);
525 return et && et == std->predef_BIT || et == std->predef_BOOLEAN;
526 }
527
528 bool
is_one_dim_discrete_array(pIIR_Type t)529 psr::is_one_dim_discrete_array (pIIR_Type t)
530 {
531 pIIR_Type et = is_one_dim_array (t);
532 return is_discrete_type (et);
533 }
534
535 bool
is_discrete_type(pIIR_Type t)536 psr::is_discrete_type (pIIR_Type t)
537 {
538 if (t == NULL)
539 return false;
540 t = t->base;
541 return t && (t->is(IR_INTEGER_TYPE)
542 || t->is(IR_ENUMERATION_TYPE));
543 }
544
545 void
add_predefined_ops(pIIR_Type t)546 psr::add_predefined_ops (pIIR_Type t)
547 {
548 if (t == NULL)
549 return;
550
551 pIIR_Type bt = t;
552
553 if (t->is(IR_SUBTYPE)
554 && t->declaration == pIIR_Subtype(t)->immediate_base->declaration)
555 bt = pIIR_Subtype(t)->immediate_base;
556 if (bt->is(VAUL_INCOMPLETE_TYPE) || bt->is(IR_SUBTYPE))
557 return;
558
559
560 # define add(r, op, t1, t2) add_PredefOp(t->pos, r, make_strlit(#op), \
561 t1, t2)
562
563 // logical operators
564 //
565 if ((t == std->predef_BIT || t == std->predef_BOOLEAN)
566 || is_one_dim_logical_array(bt))
567 {
568 add (t, "and", t, t);
569 add (t, "or", t, t);
570 add (t, "nand", t, t);
571 add (t, "nor", t, t);
572 add (t, "xor", t, t);
573 add (t, "xnor", t, t);
574 add (t, "not", t, NULL);
575 if (bt == std->predef_BOOLEAN)
576 {
577 pIIR_IntegerType ui = mIIR_IntegerType (t->pos);
578 std->universal_integer = ui;
579 add_predefined_ops(ui);
580
581 pIIR_FloatingType ur = mIIR_FloatingType (t->pos);
582 std->universal_real = ur;
583 add_predefined_ops(ur);
584 }
585 }
586
587 // relational operators
588 //
589 pIIR_Type b = std->predef_BOOLEAN;
590 if (b == NULL)
591 {
592 info ("%:can't predefine relational operators for %n", t, t);
593 info ("%:since type BOOLEAN is undefined", t);
594 }
595 else
596 {
597 add (b, "=", t, t);
598 add (b, "/=", t, t);
599 if (bt->is(IR_SCALAR_TYPE) || is_one_dim_discrete_array(bt))
600 {
601 add (b, "<", t, t);
602 add (b, ">", t, t);
603 add (b, "<=", t, t);
604 add (b, ">=", t, t);
605 }
606 }
607
608 // shift operators
609 //
610 if (is_one_dim_logical_array(bt))
611 {
612 if (pIIR_Type r = std->predef_INTEGER)
613 {
614 add (t, "sll", t, r);
615 add (t, "srl", t, r);
616 add (t, "sla", t, r);
617 add (t, "sra", t, r);
618 add (t, "rol", t, r);
619 add (t, "ror", t, r);
620 }
621 else
622 {
623 info ("%:can't predefine shift operators for %n", t, t);
624 info ("%:since type INTEGER is undefined", t);
625 }
626 }
627
628 // Adding, Sign and Miscellanous operators
629 //
630 if (bt->is(IR_INTEGER_TYPE)
631 || bt->is(IR_FLOATING_TYPE)
632 || bt->is(IR_PHYSICAL_TYPE))
633 {
634 add (t, "+", t, t);
635 add (t, "-", t, t);
636 add (t, "abs", t, NULL);
637 add (t, "+", t, NULL);
638 add (t, "-", t, NULL);
639 }
640
641 // concatenation operator
642 //
643 if(pIIR_Type et = is_one_dim_array(bt))
644 {
645 add (t, "&", t, t);
646 add (t, "&", t, et);
647 add (t, "&", et, t);
648 add (t, "&", et, et);
649 }
650
651 // Multiplying operators
652 //
653 if (bt->is(IR_INTEGER_TYPE)
654 || bt->is(IR_FLOATING_TYPE))
655 {
656 add (t, "*", t, t);
657 add (t, "/", t, t);
658 if (bt->is(IR_INTEGER_TYPE))
659 {
660 add (t, "mod", t, t);
661 add (t, "rem", t, t);
662 }
663 if (std->predef_INTEGER)
664 add (t, "**", t, std->predef_INTEGER);
665 else if (bt != std->universal_integer && bt != std->universal_real)
666 {
667 info ("%:can't predefine \"**\" operator for %n", t, t);
668 info ("%:since type INTEGER is undefined", t);
669 }
670 }
671
672 if (bt->is(IR_PHYSICAL_TYPE))
673 {
674 if (std->predef_INTEGER && std->predef_REAL)
675 {
676 add (t, "*", t, std->predef_INTEGER);
677 add (t, "*", std->predef_INTEGER, t);
678 add (t, "/", t, std->predef_INTEGER);
679 add (t, "*", t, std->predef_REAL);
680 add (t, "*", std->predef_REAL, t);
681 add (t, "/", t, std->predef_REAL);
682 }
683 else
684 {
685 info ("%:can't predefine multiplying operators for %n", t, t);
686 info ("%:since types INTEGER and REAL are undefined", t);
687 }
688 if (std->universal_integer)
689 add (std->universal_integer, "/", t, t);
690 }
691
692 if (t == std->predef_INTEGER)
693 {
694 add (std->universal_integer, "**", std->universal_integer, t);
695 add (std->universal_real, "**", std->universal_real, t);
696 }
697
698 if (t->is(IR_ACCESS_TYPE))
699 {
700 pIIR_InterfaceList parm =
701 mIIR_InterfaceList (t->pos,
702 mIIR_VariableInterfaceDeclaration (t->pos, NULL,
703 t, NULL,
704 IR_INOUT_MODE,
705 false),
706 NULL);
707 pIIR_PredefinedProcedureDeclaration dealloc =
708 mIIR_PredefinedProcedureDeclaration (t->pos,
709 make_id ("deallocate"),
710 parm);
711 add_decl(dealloc);
712 }
713
714 if (t->is(IR_FILE_TYPE))
715 {
716 pIIR_FileType ft = pIIR_FileType(t);
717
718 // FILE_OPEN
719
720 pIIR_Expression read_mode = NULL; // XXX
721
722 {
723 // long hand for finding READ_MODE
724
725 for (pIIR_DeclarationList dl = std->declarations;
726 dl; dl = dl->rest)
727 if (dl->first
728 && vaul_name_eq (dl->first->declarator, "READ_MODE"))
729 {
730 assert (dl->first->is(IR_ENUMERATION_LITERAL));
731 pIIR_EnumerationLiteral lit =
732 pIIR_EnumerationLiteral (dl->first);
733 read_mode = mIIR_EnumLiteralReference (ft->pos,
734 lit->subtype,
735 lit);
736 break;
737 }
738
739 if (read_mode == NULL)
740 error ("can't find READ_MODE in std.standard");
741 }
742
743 pIIR_InterfaceList parm =
744 mIIR_InterfaceList (t->pos,
745 mIIR_ConstantInterfaceDeclaration
746 (t->pos, make_id ("Open_Kind"),
747 std->predef_FILE_OPEN_KIND,
748 read_mode,
749 IR_IN_MODE,
750 false),
751 NULL);
752 parm =
753 mIIR_InterfaceList (t->pos,
754 mIIR_ConstantInterfaceDeclaration
755 (t->pos, make_id ("External_Name"),
756 std->predef_STRING, NULL,
757 IR_IN_MODE,
758 false),
759 parm);
760 parm =
761 mIIR_InterfaceList (t->pos,
762 mIIR_FileInterfaceDeclaration
763 (t->pos, make_id ("F"),
764 ft, NULL,
765 IR_UNKNOWN_MODE,
766 false),
767 parm);
768
769 pIIR_PredefinedProcedureDeclaration file_open1 =
770 mIIR_PredefinedProcedureDeclaration (t->pos,
771 make_id ("FILE_OPEN"),
772 parm);
773 add_decl(file_open1);
774
775 // FILE_OPEN
776
777 parm =
778 mIIR_InterfaceList (t->pos,
779 mIIR_ConstantInterfaceDeclaration
780 (t->pos, make_id ("Open_Kind"),
781 std->predef_FILE_OPEN_KIND,
782 read_mode,
783 IR_IN_MODE,
784 false),
785 NULL);
786 parm =
787 mIIR_InterfaceList (t->pos,
788 mIIR_ConstantInterfaceDeclaration
789 (t->pos, make_id ("External_Name"),
790 std->predef_STRING, NULL,
791 IR_IN_MODE,
792 false),
793 parm);
794 parm =
795 mIIR_InterfaceList (t->pos,
796 mIIR_FileInterfaceDeclaration
797 (t->pos, make_id ("F"),
798 ft, NULL,
799 IR_UNKNOWN_MODE,
800 false),
801 parm);
802 parm =
803 mIIR_InterfaceList (t->pos,
804 mIIR_VariableInterfaceDeclaration
805 (t->pos, make_id ("Status"),
806 std->predef_FILE_OPEN_STATUS, NULL,
807 IR_OUT_MODE,
808 false),
809 parm);
810
811 pIIR_PredefinedProcedureDeclaration file_open2 =
812 mIIR_PredefinedProcedureDeclaration (t->pos,
813 make_id ("FILE_OPEN"),
814 parm);
815 add_decl(file_open2);
816
817 // FILE_CLOSE
818
819 parm =
820 mIIR_InterfaceList (t->pos,
821 mIIR_FileInterfaceDeclaration
822 (t->pos, make_id ("F"),
823 ft, NULL,
824 IR_UNKNOWN_MODE,
825 false),
826 NULL);
827
828 pIIR_PredefinedProcedureDeclaration file_close =
829 mIIR_PredefinedProcedureDeclaration (t->pos,
830 make_id ("FILE_CLOSE"),
831 parm);
832 add_decl(file_close);
833
834 // READ
835
836 parm =
837 mIIR_InterfaceList (t->pos,
838 mIIR_VariableInterfaceDeclaration
839 (t->pos, make_id ("VALUE"),
840 ft->type_mark,
841 NULL,
842 IR_OUT_MODE,
843 false),
844 NULL);
845 parm =
846 mIIR_InterfaceList (t->pos,
847 mIIR_FileInterfaceDeclaration
848 (t->pos, make_id ("F"),
849 ft, NULL,
850 IR_UNKNOWN_MODE,
851 false),
852 parm);
853
854 pIIR_PredefinedProcedureDeclaration read =
855 mIIR_PredefinedProcedureDeclaration (t->pos,
856 make_id ("READ"),
857 parm);
858 add_decl(read);
859
860 // WRITE
861
862 parm =
863 mIIR_InterfaceList (t->pos,
864 mIIR_VariableInterfaceDeclaration
865 (t->pos, make_id ("VALUE"),
866 ft->type_mark,
867 NULL,
868 IR_IN_MODE,
869 false),
870 NULL);
871 parm =
872 mIIR_InterfaceList (t->pos,
873 mIIR_FileInterfaceDeclaration
874 (t->pos, make_id ("F"),
875 ft, NULL,
876 IR_UNKNOWN_MODE,
877 false),
878 parm);
879 pIIR_PredefinedProcedureDeclaration write =
880 mIIR_PredefinedProcedureDeclaration (t->pos,
881 make_id ("WRITE"),
882 parm);
883 add_decl(write);
884
885 // ENDFILE
886
887 parm =
888 mIIR_InterfaceList (t->pos,
889 mIIR_FileInterfaceDeclaration
890 (t->pos, make_id ("F"),
891 ft, NULL,
892 IR_UNKNOWN_MODE,
893 false),
894 NULL);
895 pIIR_PredefinedFunctionDeclaration endfile =
896 mIIR_PredefinedFunctionDeclaration (t->pos,
897 make_id ("ENDFILE"),
898 parm,
899 false,
900 std->predef_BOOLEAN);
901 add_decl(endfile);
902 }
903
904 # undef add
905 }
906
907 void
vaul_add_incomplete_type_use(pVAUL_IncompleteType it,pIIR_Type & ref)908 vaul_add_incomplete_type_use (pVAUL_IncompleteType it, pIIR_Type &ref)
909 {
910 assert (ref == it);
911 vaul_incomplete_type_use *u = new vaul_incomplete_type_use;
912 u->next = it->uses;
913 it->uses = u;
914 u->ref = &ref;
915 }
916
917 void
vaul_complete_incomplete_type(pVAUL_IncompleteType it,pIIR_Type t)918 vaul_complete_incomplete_type (pVAUL_IncompleteType it, pIIR_Type t)
919 {
920 for (vaul_incomplete_type_use *u = it->uses; u; u = u->next)
921 {
922 assert(*u->ref == it);
923 *u->ref = t;
924 }
925 }
926
927 pIIR_TypeList
build_PreIndexConstraint(pVAUL_GenAssocElem a)928 psr::build_PreIndexConstraint (pVAUL_GenAssocElem a)
929 {
930 pIIR_TypeList ic = NULL, *ict = ⁣
931
932 while (a)
933 {
934 pIIR_Type type = NULL;
935
936 if (a->is(VAUL_NAMED_ASSOC_ELEM))
937 {
938 pVAUL_NamedAssocElem nae = pVAUL_NamedAssocElem(a);
939 if (nae->formal)
940 error ("%:index constraints can't use named association", nae);
941 if (nae->actual && nae->actual->is(VAUL_UNRESOLVED_NAME))
942 {
943 pVAUL_Name n = pVAUL_UnresolvedName(nae->actual)->name;
944 pIIR_Type st = get_type (n);
945 if (is_discrete_type(st))
946 type = mVAUL_PreIndexSubtypeConstraint(a->pos, st);
947 else if (st)
948 error ("%: %n is not a discrete type", n, st);
949 }
950 }
951 else if (a->is(VAUL_RANGE_ASSOC_ELEM))
952 {
953 type = mVAUL_PreIndexRangeConstraint(a->pos,
954 pVAUL_RangeAssocElem(a)->range);
955 }
956 else if (a->is(VAUL_SUBTYPE_ASSOC_ELEM))
957 {
958 type = mVAUL_PreIndexSubtypeConstraint(a->pos,
959 pVAUL_SubtypeAssocElem(a)->type);
960 }
961
962 if (type)
963 {
964 *ict = mIIR_TypeList (a->pos, type, *ict);
965 ict = &(*ict)->rest;
966 }
967
968 a = a->next;
969 }
970
971 return ic;
972 }
973
974 pIIR_ScalarSubtype
make_scalar_subtype(pIIR_PosInfo pos,pIIR_Type t,int left,int right)975 psr::make_scalar_subtype (pIIR_PosInfo pos, pIIR_Type t,
976 int left, int right)
977 {
978 info ("+++ - making subtype %n %d to %d", t, left, right);
979
980 assert (t->is (IR_SCALAR_SUBTYPE));
981 pIIR_Type base = t->base;
982
983 // The expressions that we generate are
984 //
985 // t'VAL(t'POS(t'LEFT) + left) and
986 // t'VAL(t'POS(t'LEFT) + right).
987
988 char buf[128];
989
990 sprintf (buf, "%d", left);
991 pIIR_IntegerLiteral left_lit =
992 mIIR_IntegerLiteral (pos, (IR_Character *)buf, strlen(buf));
993 pIIR_Expression t_left_pos =
994 mIIR_Attr_POS (pos, std->universal_integer,
995 t, mIIR_Attr_LEFT (pos, t,
996 t, NULL));
997 pIIR_Expression t_left_new_pos =
998 build_bcall (t_left_pos, "+",
999 build_LiteralExpression (pos,
1000 left_lit));
1001 overload_resolution (t_left_new_pos, t);
1002 pIIR_Expression t_left_val =
1003 mIIR_Attr_VAL (pos, t, t, t_left_new_pos);
1004
1005 sprintf (buf, "%d", right);
1006 pIIR_IntegerLiteral right_lit =
1007 mIIR_IntegerLiteral (pos, (IR_Character *)buf, strlen(buf));
1008 pIIR_Expression t_right_pos =
1009 mIIR_Attr_POS (pos, std->universal_integer,
1010 t, mIIR_Attr_LEFT (pos, t,
1011 t, NULL));
1012 pIIR_Expression t_right_new_pos =
1013 build_bcall (t_right_pos, "+",
1014 build_LiteralExpression (pos,
1015 right_lit));
1016 overload_resolution (t_right_new_pos, t);
1017 pIIR_Expression t_right_val =
1018 mIIR_Attr_VAL (pos, t, t, t_right_new_pos);
1019
1020 return mIIR_ScalarSubtype (pos,
1021 t->base, t,
1022 NULL,
1023 mIIR_ExplicitRange (pos,
1024 t_left_val,
1025 t_right_val,
1026 IR_DIRECTION_UP));
1027 }
1028
1029 static int
stringlitlen(pIIR_StringLiteral str)1030 stringlitlen (pIIR_StringLiteral str)
1031 {
1032 IR_String &s = str->text;
1033 int q = 0;
1034 for (int i = 1; i < s.len()-1; i++)
1035 if (s[i] == '"')
1036 q++;
1037 return s.len()-2-q/2;
1038 }
1039
1040 pIIR_Type
adapt_object_type(VAUL_ObjectClass c,pIIR_Type t,pIIR_Expression init)1041 psr::adapt_object_type (VAUL_ObjectClass c,
1042 pIIR_Type t,
1043 pIIR_Expression init)
1044 {
1045 if (t == NULL)
1046 return NULL;
1047
1048 if (c == VAUL_ObjClass_Variable || c == VAUL_ObjClass_Signal)
1049 {
1050 if (t->is(IR_ARRAY_TYPE))
1051 error("array objects must have a constrained type");
1052 return t;
1053 }
1054
1055 if (c == VAUL_ObjClass_Constant)
1056 {
1057 if (init == NULL || !t->is(IR_ARRAY_TYPE))
1058 return t;
1059
1060 pIIR_ArrayType at = pIIR_ArrayType(t);
1061
1062 if (init->subtype && init->subtype->is (IR_ARRAY_SUBTYPE))
1063 return init->subtype;
1064
1065 if (init->is (IR_ARRAY_LITERAL_EXPRESSION)
1066 || init->is (VAUL_AMBG_ARRAY_LIT_REF))
1067 {
1068 assert (at->index_types && at->index_types->rest == NULL);
1069
1070 pIIR_StringLiteral value;
1071 if (init->is (IR_ARRAY_LITERAL_EXPRESSION))
1072 value = pIIR_ArrayLiteralExpression(init)->value;
1073 else
1074 value = pVAUL_AmbgArrayLitRef(init)->value;
1075
1076 // This is actually not correct as left bound and range
1077 // direction of the array index are determined from the
1078 // unconstrained array type. I.e., left index bound and
1079 // direction = left index bound and direction of
1080 // unconstrained array (and not necessarily 0)!
1081 pIIR_ScalarSubtype st = make_scalar_subtype (init->pos,
1082 at->index_types->first,
1083 0,
1084 stringlitlen (value) - 1);
1085 if (st == NULL)
1086 return t;
1087
1088 pIIR_ArraySubtype as =
1089 mIIR_ArraySubtype (init->pos,
1090 t->base,
1091 t, NULL, mIIR_TypeList (init->pos,
1092 st, NULL));
1093 return as;
1094 }
1095 else if (init->is (VAUL_AMBG_AGGREGATE))
1096 {
1097 if (at->index_types->rest)
1098 {
1099 //error ("can't determine array subtype from
1100 //multi-dimensional aggregates, yet.");
1101
1102 //Note: this is currently done by the code generator!
1103 //Hence, do not produce an error message.
1104 return t;
1105 }
1106
1107 int n = 0;
1108 for (pVAUL_ElemAssoc ea = pVAUL_AmbgAggregate (init)->first_assoc;
1109 ea; ea = ea->next)
1110 {
1111 if (ea->choices)
1112 {
1113 //error ("can't determine array subtype from
1114 //aggregates with index associations, yet.");
1115
1116 //Note: this is currently done by the code
1117 //generator! Hence, do not produce an error message.
1118 return t;
1119 }
1120 n += 1;
1121 }
1122
1123 pIIR_ScalarSubtype st = make_scalar_subtype (init->pos,
1124 at->index_types->first,
1125 0, n-1);
1126 if (st == NULL)
1127 return t;
1128
1129 pIIR_ArraySubtype as =
1130 mIIR_ArraySubtype (init->pos,
1131 t->base,
1132 t, NULL, mIIR_TypeList (init->pos,
1133 st, NULL));
1134 return as;
1135 }
1136 else
1137 {
1138 // error ("can't determine array subtype from %s yet.",
1139 // init->kind_name ());
1140
1141 //Note: this is currently done by the code
1142 //generator! Hence, do not produce an error message.
1143 return t;
1144 }
1145 }
1146 else
1147 info ("xxx - unchecked object type");
1148
1149 return t;
1150 }
1151
1152 pIIR_ArraySubtype
build_constrained_array_type(pIIR_TypeList pre,pIIR_Type elt)1153 psr::build_constrained_array_type (pIIR_TypeList pre,
1154 pIIR_Type elt)
1155 {
1156 pIIR_TypeList itypes = NULL, *itail = &itypes;
1157
1158 for (pIIR_TypeList p = pre; p; p = p->rest)
1159 {
1160 pIIR_Type it, pt = p->first;
1161
1162 if (pt->is(VAUL_PRE_INDEX_SUBTYPE_CONSTRAINT))
1163 it = pVAUL_PreIndexSubtypeConstraint(pt)->type;
1164 else if (pt->is(VAUL_PRE_INDEX_RANGE_CONSTRAINT))
1165 {
1166 pIIR_Range r = pVAUL_PreIndexRangeConstraint(pt)->range;
1167 if (r == NULL)
1168 return NULL;
1169 if (r->is(IR_EXPLICIT_RANGE))
1170 it = find_index_range_type (pIIR_ExplicitRange(r));
1171 else if (r->is(IR_ARRAY_RANGE))
1172 it = pIIR_ArrayRange(r)->type;
1173 else
1174 assert (false);
1175 }
1176 else
1177 assert(false);
1178
1179 *itail = mIIR_TypeList(p->pos, it, NULL);
1180 itail = &(*itail)->rest;
1181 }
1182
1183 pIIR_ArrayType base = mIIR_ArrayType(pre? pre->pos:NULL, itypes, elt);
1184 return mIIR_ArraySubtype (base->pos, base,
1185 base, NULL, build_IndexConstraint (pre, base));
1186 }
1187
1188 bool
legal_file_type(pIIR_Type t)1189 psr::legal_file_type (pIIR_Type t)
1190 {
1191 if (t == NULL)
1192 return true;
1193
1194 pIIR_Type b = t->base;
1195
1196 if (b->is(IR_FILE_TYPE)
1197 || b->is(IR_ACCESS_TYPE)
1198 /* || b->is(IR_PROTECTED_TYPE) */ )
1199 {
1200 error ("%n can not be used as the contents of a file", b);
1201 return false;
1202 }
1203
1204 if (b->is(IR_ARRAY_TYPE))
1205 {
1206 pIIR_ArrayType at = pIIR_ArrayType(b);
1207 if (at->index_types && at->index_types->rest != NULL)
1208 {
1209 error ("only one dimensional arrays can be used with files");
1210 return false;
1211 }
1212 return legal_file_type (at->element_type);
1213 }
1214
1215 if (b->is(IR_RECORD_TYPE))
1216 {
1217 pIIR_RecordType rt = pIIR_RecordType (b);
1218 bool result = true;
1219 for (pIIR_ElementDeclarationList elts = rt->element_declarations;
1220 elts; elts = elts->rest)
1221 {
1222 if (elts->first && !legal_file_type (elts->first->subtype))
1223 result = false;
1224 }
1225 return result;
1226 }
1227
1228 return true;
1229 }
1230
1231 pIIR_FileType
build_FileType(pVAUL_Name type_mark)1232 psr::build_FileType (pVAUL_Name type_mark)
1233 {
1234 pIIR_Type ct = get_type (type_mark);
1235 if (!legal_file_type (ct))
1236 return NULL;
1237 return mIIR_FileType (type_mark->pos, ct);
1238 }
1239
1240 pIIR_FileDeclaration
add_File(pIIR_Identifier id,pIIR_Type file_type,pIIR_Expression mode,pVAUL_FilenameAndMode name_and_mode)1241 psr::add_File (pIIR_Identifier id,
1242 pIIR_Type file_type,
1243 pIIR_Expression mode,
1244 pVAUL_FilenameAndMode name_and_mode)
1245 {
1246 if (!file_type->is(IR_FILE_TYPE))
1247 {
1248 error ("%:%n is not a file type", id, file_type);
1249 return NULL;
1250 }
1251 if (name_and_mode && name_and_mode->mode != IR_UNKNOWN_MODE)
1252 {
1253 const char *mode_id;
1254
1255 if (mode != NULL)
1256 {
1257 error ("%:mixed '93 and '87 syntax in file declaration", id);
1258 return NULL;
1259 }
1260 if (name_and_mode->mode == IR_IN_MODE)
1261 mode_id = "READ_MODE";
1262 else if (name_and_mode->mode == IR_OUT_MODE)
1263 mode_id = "WRITE_MODE";
1264 else
1265 abort ();
1266
1267 pIIR_PosInfo pos = name_and_mode->name->pos;
1268 pVAUL_Name mode_name =
1269 mVAUL_SelName (pos,
1270 mVAUL_SelName (pos,
1271 mVAUL_SimpleName (pos, make_id ("std")),
1272 make_id ("standard")),
1273 make_id (mode_id));
1274 mode = build_Expr (mode_name);
1275 overload_resolution (mode, std->predef_FILE_OPEN_KIND);
1276 }
1277
1278 return pIIR_FileDeclaration (
1279 add_decl(mIIR_FileDeclaration (id->pos, id, file_type,
1280 NULL, mode,
1281 (name_and_mode?
1282 name_and_mode->name : NULL))));
1283 }
1284
1285 pIIR_Type
m_vaul_get_base(pIIR_Type t)1286 m_vaul_get_base (pIIR_Type t)
1287 {
1288 return t->base;
1289 }
1290
1291 void
vaul_fix_static_level(pIIR_Type t)1292 vaul_fix_static_level (pIIR_Type t)
1293 {
1294 t->static_level = vaul_compute_static_level (t);
1295 }
1296
1297 IR_StaticLevel
m_vaul_compute_static_level(pIIR_RecordType t)1298 m_vaul_compute_static_level (pIIR_RecordType t)
1299 {
1300 IR_StaticLevel lev = IR_LOCALLY_STATIC;
1301 for (pIIR_ElementDeclarationList el = t->element_declarations;
1302 el; el = el->rest)
1303 lev = vaul_merge_levels (lev, el->first->subtype->static_level);
1304 return lev;
1305 }
1306
1307 IR_StaticLevel
m_vaul_compute_static_level(pIIR_RecordSubtype t)1308 m_vaul_compute_static_level (pIIR_RecordSubtype t)
1309 {
1310 return t->base->static_level;
1311 }
1312
1313 IR_StaticLevel
m_vaul_compute_static_level(pIIR_ArrayType t)1314 m_vaul_compute_static_level (pIIR_ArrayType t)
1315 {
1316 return IR_NOT_STATIC;
1317 }
1318
1319 IR_StaticLevel
m_vaul_compute_static_level(pIIR_ArraySubtype t)1320 m_vaul_compute_static_level (pIIR_ArraySubtype t)
1321 {
1322 // Note: the static level of the base type does not enter the
1323 // definition.
1324
1325 IR_StaticLevel lev = IR_LOCALLY_STATIC;
1326 for (pIIR_TypeList cl = t->constraint; cl; cl = cl->rest)
1327 lev = vaul_merge_levels (lev, cl->first->static_level);
1328 return lev;
1329 }
1330
1331 IR_StaticLevel
m_vaul_compute_static_level(pIIR_ScalarSubtype t)1332 m_vaul_compute_static_level (pIIR_ScalarSubtype t)
1333 {
1334 IR_StaticLevel lev = t->base->static_level;
1335 if (t->range)
1336 lev = vaul_merge_levels (lev, vaul_compute_static_level (t->range));
1337 return lev;
1338 }
1339
1340 IR_StaticLevel
m_vaul_compute_static_level(pIIR_Type t)1341 m_vaul_compute_static_level (pIIR_Type t)
1342 {
1343 // All types except the ones handled above are unconditionally
1344 // locally static. This includes file types with non-static element
1345 // types, for example.
1346
1347 return IR_LOCALLY_STATIC;
1348 }
1349