1 /* Implement grant-file output & seize-file input for CHILL.
2 Copyright (C) 1992, 93, 94, 95, 1996 Free Software Foundation, Inc.
4 This file is part of GNU CC.
6 GNU CC is free software; you can redistribute it and/or modify
7 it under the terms of the GNU General Public License as published by
8 the Free Software Foundation; either version 2, or (at your option)
11 GNU CC is distributed in the hope that it will be useful,
12 but WITHOUT ANY WARRANTY; without even the implied warranty of
13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 GNU General Public License for more details.
16 You should have received a copy of the GNU General Public License
17 along with GNU CC; see the file COPYING. If not, write to
18 the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
33 #define APPEND(X,Y) X = append (X, Y)
34 #define PREPEND(X,Y) X = prepend (X, Y);
35 #define FREE(x) strfree (x)
36 #define ALLOCAMOUNT 10000
37 /* may be we can handle this in a more exciting way,
38 but this also should work for the moment */
39 #define MAYBE_NEWLINE(X) \
42 if (X->len && X->str[X->len - 1] != '\n') \
46 extern tree process_type;
47 extern char *asm_file_name;
48 extern char *dump_base_name;
50 /* forward declarations */
52 /* variable indicates compilation at module level */
53 int chill_at_module_level = 0;
56 /* mark that a SPEC MODULE was generated */
57 static int spec_module_generated = 0;
59 /* define version strings */
60 extern char *gnuchill_version;
61 extern char *version_string;
63 /* define a faster string handling */
71 /* structure used for handling multiple grant files */
72 char *grant_file_name;
73 MYSTRING *gstring = NULL;
74 MYSTRING *selective_gstring = NULL;
76 static MYSTRING *decode_decl PROTO((tree));
77 static MYSTRING *decode_constant PROTO((tree));
78 static void grant_one_decl PROTO((tree));
79 static MYSTRING *get_type PROTO((tree));
80 static MYSTRING *decode_mode PROTO((tree));
81 static MYSTRING *decode_prefix_rename PROTO((tree));
82 static MYSTRING *decode_constant_selective PROTO((tree, tree));
83 static MYSTRING *decode_mode_selective PROTO((tree, tree));
84 static MYSTRING *get_type_selective PROTO((tree, tree));
85 static MYSTRING *decode_decl_selective PROTO((tree, tree));
87 /* list of the VAR_DECLs of the module initializer entries */
88 tree module_init_list = NULL_TREE;
90 /* handle different USE_SEIZE_FILE's in case of selective granting */
91 typedef struct SEIZEFILELIST
93 struct SEIZEFILELIST *next;
98 static seizefile_list *selective_seizes = 0;
105 MYSTRING *tmp = (MYSTRING *) xmalloc (sizeof (MYSTRING));
106 unsigned len = strlen (str);
108 tmp->allocated = len + ALLOCAMOUNT;
109 tmp->str = xmalloc ((unsigned)tmp->allocated);
110 strcpy (tmp->str, str);
128 int inlen = strlen (in);
129 int amount = ALLOCAMOUNT;
133 if ((inout->len + inlen) >= inout->allocated)
134 inout->str = xrealloc (inout->str, inout->allocated += amount);
135 strcpy (inout->str + inout->len, in);
145 MYSTRING *res = inout;
148 res = newstring (in);
149 res = APPEND (res, inout->str);
156 grant_use_seizefile (seize_filename)
157 char *seize_filename;
159 APPEND (gstring, "<> USE_SEIZE_FILE \"");
160 APPEND (gstring, seize_filename);
161 APPEND (gstring, "\" <>\n");
165 decode_layout (layout)
169 tree stepsize = NULL_TREE;
171 MYSTRING *result = newstring ("");
174 if (layout == integer_zero_node) /* NOPACK */
176 APPEND (result, " NOPACK");
180 if (layout == integer_one_node) /* PACK */
182 APPEND (result, " PACK");
186 APPEND (result, " ");
188 if (TREE_PURPOSE (temp) == NULL_TREE)
190 APPEND (result, "STEP(");
192 temp = TREE_VALUE (temp);
193 stepsize = TREE_VALUE (temp);
195 APPEND (result, "POS(");
197 /* Get the starting word */
198 temp = TREE_PURPOSE (temp);
199 work = decode_constant (TREE_PURPOSE (temp));
200 APPEND (result, work->str);
203 temp = TREE_VALUE (temp);
204 if (temp != NULL_TREE)
206 /* Get the starting bit */
207 APPEND (result, ", ");
208 work = decode_constant (TREE_PURPOSE (temp));
209 APPEND (result, work->str);
212 temp = TREE_VALUE (temp);
213 if (temp != NULL_TREE)
215 /* Get the length or the ending bit */
216 tree what = TREE_PURPOSE (temp);
217 if (what == integer_zero_node) /* length */
219 APPEND (result, ", ");
223 APPEND (result, ":");
225 work = decode_constant (TREE_VALUE (temp));
226 APPEND (result, work->str);
230 APPEND (result, ")");
234 if (stepsize != NULL_TREE)
236 APPEND (result, ", ");
237 work = decode_constant (stepsize);
238 APPEND (result, work->str);
241 APPEND (result, ")");
248 grant_array_type (type)
251 MYSTRING *result = newstring ("");
252 MYSTRING *mode_string;
256 if (chill_varying_type_p (type))
259 type = CH_VARYING_ARRAY_TYPE (type);
261 if (CH_STRING_TYPE_P (type))
263 tree fields = TYPE_DOMAIN (type);
264 tree maxval = TYPE_MAX_VALUE (fields);
266 if (TREE_CODE (TREE_TYPE (type)) == CHAR_TYPE)
267 APPEND (result, "CHARS (");
269 APPEND (result, "BOOLS (");
270 if (TREE_CODE (maxval) == INTEGER_CST)
273 sprintf (wrk, "%d", TREE_INT_CST_LOW (maxval) + 1);
274 APPEND (result, wrk);
276 else if (TREE_CODE (maxval) == MINUS_EXPR
277 && TREE_OPERAND (maxval, 1) == integer_one_node)
279 mode_string = decode_constant (TREE_OPERAND (maxval, 0));
280 APPEND (result, mode_string->str);
285 mode_string = decode_constant (maxval);
286 APPEND (result, mode_string->str);
288 APPEND (result, "+1");
290 APPEND (result, ")");
292 APPEND (result, " VARYING");
296 APPEND (result, "ARRAY (");
297 if (TREE_CODE (TYPE_DOMAIN (type)) == INTEGER_TYPE
298 && TREE_TYPE (TYPE_DOMAIN (type)) == ridpointers[(int) RID_RANGE])
300 mode_string = decode_constant (TYPE_MIN_VALUE (TYPE_DOMAIN (type)));
301 APPEND (result, mode_string->str);
304 APPEND (result, ":");
305 mode_string = decode_constant (TYPE_MAX_VALUE (TYPE_DOMAIN (type)));
306 APPEND (result, mode_string->str);
311 mode_string = decode_mode (TYPE_DOMAIN (type));
312 APPEND (result, mode_string->str);
315 APPEND (result, ") ");
317 APPEND (result, "VARYING ");
319 mode_string = get_type (TREE_TYPE (type));
320 APPEND (result, mode_string->str);
323 layout = TYPE_ATTRIBUTES (type);
324 if (layout != NULL_TREE)
326 mode_string = decode_layout (layout);
327 APPEND (result, mode_string->str);
335 grant_array_type_selective (type, all_decls)
339 MYSTRING *result = newstring ("");
340 MYSTRING *mode_string;
343 if (chill_varying_type_p (type))
346 type = CH_VARYING_ARRAY_TYPE (type);
348 if (CH_STRING_TYPE_P (type))
350 tree fields = TYPE_DOMAIN (type);
351 tree maxval = TYPE_MAX_VALUE (fields);
353 if (TREE_CODE (maxval) != INTEGER_CST)
355 if (TREE_CODE (maxval) == MINUS_EXPR
356 && TREE_OPERAND (maxval, 1) == integer_one_node)
358 mode_string = decode_constant_selective (TREE_OPERAND (maxval, 0), all_decls);
359 if (mode_string->len)
360 APPEND (result, mode_string->str);
365 mode_string = decode_constant_selective (maxval, all_decls);
366 if (mode_string->len)
367 APPEND (result, mode_string->str);
374 if (TREE_CODE (TYPE_DOMAIN (type)) == INTEGER_TYPE
375 && TREE_TYPE (TYPE_DOMAIN (type)) == ridpointers[(int) RID_RANGE])
377 mode_string = decode_constant_selective (TYPE_MIN_VALUE (TYPE_DOMAIN (type)), all_decls);
378 if (mode_string->len)
379 APPEND (result, mode_string->str);
382 mode_string = decode_constant_selective (TYPE_MAX_VALUE (TYPE_DOMAIN (type)), all_decls);
383 if (mode_string->len)
385 MAYBE_NEWLINE (result);
386 APPEND (result, mode_string->str);
392 mode_string = decode_mode_selective (TYPE_DOMAIN (type), all_decls);
393 if (mode_string->len)
394 APPEND (result, mode_string->str);
398 mode_string = get_type_selective (TREE_TYPE (type), all_decls);
399 if (mode_string->len)
401 MAYBE_NEWLINE (result);
402 APPEND (result, mode_string->str);
415 if (TREE_CODE (val) == CONST_DECL && DECL_NAME (val))
417 result = newstring (IDENTIFIER_POINTER (DECL_NAME (val)));
419 else if (TREE_CODE (val) == CONST_DECL)
421 /* it's a synonym -- get the value */
422 result = decode_constant (DECL_INITIAL (val));
426 result = decode_constant (val);
432 get_tag_value_selective (val, all_decls)
438 if (TREE_CODE (val) == CONST_DECL && DECL_NAME (val))
439 result = newstring ("");
440 else if (TREE_CODE (val) == CONST_DECL)
442 /* it's a synonym -- get the value */
443 result = decode_constant_selective (DECL_INITIAL (val), all_decls);
447 result = decode_constant_selective (val, all_decls);
453 print_enumeral (type)
456 MYSTRING *result = newstring ("");
460 if (TYPE_LANG_SPECIFIC (type) == NULL)
464 APPEND (result, "SET (");
465 for (fields = TYPE_VALUES (type);
467 fields = TREE_CHAIN (fields))
469 if (TREE_PURPOSE (fields) == NULL_TREE)
470 APPEND (result, "*");
473 tree decl = TREE_VALUE (fields);
474 APPEND (result, IDENTIFIER_POINTER (TREE_PURPOSE (fields)));
475 if (TREE_CODE (decl) == CONST_DECL && DECL_INITIAL (decl))
477 MYSTRING *val_string = decode_constant (DECL_INITIAL (decl));
478 APPEND (result, " = ");
479 APPEND (result, val_string->str);
483 if (TREE_CHAIN (fields) != NULL_TREE)
484 APPEND (result, ",\n ");
486 APPEND (result, ")");
492 print_enumeral_selective (type, all_decls)
496 MYSTRING *result = newstring ("");
499 for (fields = TYPE_VALUES (type);
501 fields = TREE_CHAIN (fields))
503 if (TREE_PURPOSE (fields) != NULL_TREE)
505 tree decl = TREE_VALUE (fields);
506 if (TREE_CODE (decl) == CONST_DECL && DECL_INITIAL (decl))
508 MYSTRING *val_string = decode_constant_selective (DECL_INITIAL (decl), all_decls);
510 APPEND (result, val_string->str);
519 print_integer_type (type)
522 MYSTRING *result = newstring ("");
523 MYSTRING *mode_string;
527 if (TREE_TYPE (type))
529 mode_string = decode_mode (TREE_TYPE (type));
530 APPEND (result, mode_string->str);
533 APPEND (result, "(");
534 mode_string = decode_constant (TYPE_MIN_VALUE (type));
535 APPEND (result, mode_string->str);
538 if (TREE_TYPE (type) != ridpointers[(int) RID_BIN])
540 APPEND (result, ":");
541 mode_string = decode_constant (TYPE_MAX_VALUE (type));
542 APPEND (result, mode_string->str);
546 APPEND (result, ")");
549 /* We test TYPE_MAIN_VARIANT because pushdecl often builds
550 a copy of a built-in type node, which is logically id-
551 entical but has a different address, and the same
552 TYPE_MAIN_VARIANT. */
553 /* FIXME this should not be needed! */
555 base_type = TREE_TYPE (type) ? TREE_TYPE (type) : type;
557 if (TREE_UNSIGNED (base_type))
559 if (base_type == chill_unsigned_type_node
560 || TYPE_MAIN_VARIANT(base_type) ==
561 TYPE_MAIN_VARIANT (chill_unsigned_type_node))
563 else if (base_type == long_integer_type_node
564 || TYPE_MAIN_VARIANT(base_type) ==
565 TYPE_MAIN_VARIANT (long_unsigned_type_node))
567 else if (type == unsigned_char_type_node
568 || TYPE_MAIN_VARIANT(base_type) ==
569 TYPE_MAIN_VARIANT (unsigned_char_type_node))
571 else if (type == duration_timing_type_node
572 || TYPE_MAIN_VARIANT (base_type) ==
573 TYPE_MAIN_VARIANT (duration_timing_type_node))
574 name_ptr = "DURATION";
575 else if (type == abs_timing_type_node
576 || TYPE_MAIN_VARIANT (base_type) ==
577 TYPE_MAIN_VARIANT (abs_timing_type_node))
584 if (base_type == chill_integer_type_node
585 || TYPE_MAIN_VARIANT (base_type) ==
586 TYPE_MAIN_VARIANT (chill_integer_type_node))
588 else if (base_type == long_integer_type_node
589 || TYPE_MAIN_VARIANT (base_type) ==
590 TYPE_MAIN_VARIANT (long_integer_type_node))
592 else if (type == signed_char_type_node
593 || TYPE_MAIN_VARIANT (base_type) ==
594 TYPE_MAIN_VARIANT (signed_char_type_node))
600 APPEND (result, name_ptr);
602 /* see if we have a range */
603 if (TREE_TYPE (type) != NULL)
605 mode_string = decode_constant (TYPE_MIN_VALUE (type));
606 APPEND (result, mode_string->str);
608 APPEND (result, ":");
609 mode_string = decode_constant (TYPE_MAX_VALUE (type));
610 APPEND (result, mode_string->str);
618 find_enum_parent (enumname, all_decls)
624 for (wrk = all_decls; wrk != NULL_TREE; wrk = TREE_CHAIN (wrk))
626 if (TREE_TYPE (wrk) != NULL_TREE && TREE_CODE (wrk) != CONST_DECL &&
627 TREE_CODE (TREE_TYPE (wrk)) == ENUMERAL_TYPE)
630 for (list = TYPE_VALUES (TREE_TYPE (wrk)); list != NULL_TREE; list = TREE_CHAIN (list))
632 if (DECL_NAME (TREE_VALUE (list)) == enumname)
641 print_integer_selective (type, all_decls)
645 MYSTRING *result = newstring ("");
646 MYSTRING *mode_string;
648 if (TREE_TYPE (type))
650 mode_string = decode_mode_selective (TREE_TYPE (type), all_decls);
651 if (mode_string->len)
652 APPEND (result, mode_string->str);
655 if (TREE_TYPE (type) == ridpointers[(int)RID_RANGE] &&
656 TREE_CODE (TYPE_MIN_VALUE (type)) == IDENTIFIER_NODE &&
657 TREE_CODE (TYPE_MAX_VALUE (type)) == IDENTIFIER_NODE)
659 /* we have a range of a set. Find parant mode and write it
660 to SPEC MODULE. This will loose if the parent mode was SEIZED from
662 tree minparent = find_enum_parent (TYPE_MIN_VALUE (type), all_decls);
663 tree maxparent = find_enum_parent (TYPE_MAX_VALUE (type), all_decls);
665 if (minparent != NULL_TREE)
667 if (! CH_ALREADY_GRANTED (minparent))
669 mode_string = decode_decl (minparent);
670 if (mode_string->len)
671 APPEND (result, mode_string->str);
673 CH_ALREADY_GRANTED (minparent) = 1;
676 if (minparent != maxparent && maxparent != NULL_TREE)
678 if (!CH_ALREADY_GRANTED (maxparent))
680 mode_string = decode_decl (maxparent);
681 if (mode_string->len)
683 MAYBE_NEWLINE (result);
684 APPEND (result, mode_string->str);
687 CH_ALREADY_GRANTED (maxparent) = 1;
693 mode_string = decode_constant_selective (TYPE_MIN_VALUE (type), all_decls);
694 if (mode_string->len)
696 MAYBE_NEWLINE (result);
697 APPEND (result, mode_string->str);
701 mode_string = decode_constant_selective (TYPE_MAX_VALUE (type), all_decls);
702 if (mode_string->len)
704 MAYBE_NEWLINE (result);
705 APPEND (result, mode_string->str);
712 /* see if we have a range */
713 if (TREE_TYPE (type) != NULL)
715 mode_string = decode_constant_selective (TYPE_MIN_VALUE (type), all_decls);
716 if (mode_string->len)
717 APPEND (result, mode_string->str);
720 mode_string = decode_constant_selective (TYPE_MAX_VALUE (type), all_decls);
721 if (mode_string->len)
723 MAYBE_NEWLINE (result);
724 APPEND (result, mode_string->str);
736 MYSTRING *result = newstring ("");
737 MYSTRING *mode_string;
740 if (chill_varying_type_p (type))
742 mode_string = grant_array_type (type);
743 APPEND (result, mode_string->str);
748 fields = TYPE_FIELDS (type);
750 APPEND (result, "STRUCT (");
751 while (fields != NULL_TREE)
753 if (TREE_CODE (TREE_TYPE (fields)) == UNION_TYPE)
756 /* Format a tagged variant record type. */
757 APPEND (result, " CASE ");
758 if (TYPE_TAGFIELDS (TREE_TYPE (fields)) != NULL_TREE)
760 tree tag_list = TYPE_TAGFIELDS (TREE_TYPE (fields));
763 tree tag_name = DECL_NAME (TREE_VALUE (tag_list));
764 APPEND (result, IDENTIFIER_POINTER (tag_name));
765 tag_list = TREE_CHAIN (tag_list);
766 if (tag_list == NULL_TREE)
768 APPEND (result, ", ");
771 APPEND (result, " OF\n");
772 variants = TYPE_FIELDS (TREE_TYPE (fields));
774 /* Each variant is a FIELD_DECL whose type is an anonymous
775 struct within the anonymous union. */
776 while (variants != NULL_TREE)
778 tree tag_list = TYPE_TAG_VALUES (TREE_TYPE (variants));
779 tree struct_elts = TYPE_FIELDS (TREE_TYPE (variants));
781 while (tag_list != NULL_TREE)
783 tree tag_values = TREE_VALUE (tag_list);
784 APPEND (result, " (");
785 while (tag_values != NULL_TREE)
787 mode_string = get_tag_value (TREE_VALUE (tag_values));
788 APPEND (result, mode_string->str);
790 if (TREE_CHAIN (tag_values) != NULL_TREE)
792 APPEND (result, ",\n ");
793 tag_values = TREE_CHAIN (tag_values);
797 APPEND (result, ")");
798 tag_list = TREE_CHAIN (tag_list);
800 APPEND (result, ",");
804 APPEND (result, " : ");
806 while (struct_elts != NULL_TREE)
808 mode_string = decode_decl (struct_elts);
809 APPEND (result, mode_string->str);
812 if (TREE_CHAIN (struct_elts) != NULL_TREE)
813 APPEND (result, ",\n ");
814 struct_elts = TREE_CHAIN (struct_elts);
817 variants = TREE_CHAIN (variants);
818 if (variants != NULL_TREE
819 && TREE_CHAIN (variants) == NULL_TREE
820 && DECL_NAME (variants) == ELSE_VARIANT_NAME)
822 tree else_elts = TYPE_FIELDS (TREE_TYPE (variants));
823 APPEND (result, "\n ELSE ");
824 while (else_elts != NULL_TREE)
826 mode_string = decode_decl (else_elts);
827 APPEND (result, mode_string->str);
829 if (TREE_CHAIN (else_elts) != NULL_TREE)
830 APPEND (result, ",\n ");
831 else_elts = TREE_CHAIN (else_elts);
835 if (variants != NULL_TREE)
836 APPEND (result, ",\n");
839 APPEND (result, "\n ESAC");
843 mode_string = decode_decl (fields);
844 APPEND (result, mode_string->str);
848 fields = TREE_CHAIN (fields);
849 if (fields != NULL_TREE)
850 APPEND (result, ",\n ");
852 APPEND (result, ")");
858 print_struct_selective (type, all_decls)
862 MYSTRING *result = newstring ("");
863 MYSTRING *mode_string;
866 if (chill_varying_type_p (type))
868 mode_string = grant_array_type_selective (type, all_decls);
869 if (mode_string->len)
870 APPEND (result, mode_string->str);
875 fields = TYPE_FIELDS (type);
877 while (fields != NULL_TREE)
879 if (TREE_CODE (TREE_TYPE (fields)) == UNION_TYPE)
882 /* Format a tagged variant record type. */
884 variants = TYPE_FIELDS (TREE_TYPE (fields));
886 /* Each variant is a FIELD_DECL whose type is an anonymous
887 struct within the anonymous union. */
888 while (variants != NULL_TREE)
890 tree tag_list = TYPE_TAG_VALUES (TREE_TYPE (variants));
891 tree struct_elts = TYPE_FIELDS (TREE_TYPE (variants));
893 while (tag_list != NULL_TREE)
895 tree tag_values = TREE_VALUE (tag_list);
896 while (tag_values != NULL_TREE)
898 mode_string = get_tag_value_selective (TREE_VALUE (tag_values),
900 if (mode_string->len)
902 MAYBE_NEWLINE (result);
903 APPEND (result, mode_string->str);
906 if (TREE_CHAIN (tag_values) != NULL_TREE)
907 tag_values = TREE_CHAIN (tag_values);
910 tag_list = TREE_CHAIN (tag_list);
915 while (struct_elts != NULL_TREE)
917 mode_string = decode_decl_selective (struct_elts, all_decls);
918 if (mode_string->len)
920 MAYBE_NEWLINE (result);
921 APPEND (result, mode_string->str);
925 struct_elts = TREE_CHAIN (struct_elts);
928 variants = TREE_CHAIN (variants);
929 if (variants != NULL_TREE
930 && TREE_CHAIN (variants) == NULL_TREE
931 && DECL_NAME (variants) == ELSE_VARIANT_NAME)
933 tree else_elts = TYPE_FIELDS (TREE_TYPE (variants));
934 while (else_elts != NULL_TREE)
936 mode_string = decode_decl_selective (else_elts, all_decls);
937 if (mode_string->len)
939 MAYBE_NEWLINE (result);
940 APPEND (result, mode_string->str);
943 else_elts = TREE_CHAIN (else_elts);
951 mode_string = decode_decl_selective (fields, all_decls);
952 APPEND (result, mode_string->str);
956 fields = TREE_CHAIN (fields);
963 print_proc_exceptions (ex)
966 MYSTRING *result = newstring ("");
970 APPEND (result, "\n EXCEPTIONS (");
971 for ( ; ex != NULL_TREE; ex = TREE_CHAIN (ex))
973 APPEND (result, IDENTIFIER_POINTER (TREE_VALUE (ex)));
974 if (TREE_CHAIN (ex) != NULL_TREE)
975 APPEND (result, ",\n ");
977 APPEND (result, ")");
983 print_proc_tail (type, args, print_argnames)
988 MYSTRING *result = newstring ("");
989 MYSTRING *mode_string;
991 int stopat = list_length (args) - 3;
993 /* do the argument modes */
994 for ( ; args != NULL_TREE;
995 args = TREE_CHAIN (args), count++)
998 tree argmode = TREE_VALUE (args);
999 tree attribute = TREE_PURPOSE (args);
1001 if (argmode == void_type_node)
1004 /* if we have exceptions don't print last 2 arguments */
1005 if (TYPE_RAISES_EXCEPTIONS (type) && count == stopat)
1009 APPEND (result, ",\n ");
1012 sprintf(buf, "arg%d ", count);
1013 APPEND (result, buf);
1016 if (attribute == ridpointers[(int) RID_LOC])
1017 argmode = TREE_TYPE (argmode);
1018 mode_string = get_type (argmode);
1019 APPEND (result, mode_string->str);
1022 if (attribute != NULL_TREE)
1024 sprintf (buf, " %s", IDENTIFIER_POINTER (attribute));
1025 APPEND (result, buf);
1028 APPEND (result, ")");
1032 tree retn_type = TREE_TYPE (type);
1034 if (retn_type != NULL_TREE
1035 && TREE_CODE (retn_type) != VOID_TYPE)
1037 mode_string = get_type (retn_type);
1038 APPEND (result, "\n RETURNS (");
1039 APPEND (result, mode_string->str);
1041 if (TREE_CODE (retn_type) == REFERENCE_TYPE)
1042 APPEND (result, " LOC");
1043 APPEND (result, ")");
1047 mode_string = print_proc_exceptions (TYPE_RAISES_EXCEPTIONS (type));
1048 APPEND (result, mode_string->str);
1055 print_proc_tail_selective (type, args, all_decls)
1060 MYSTRING *result = newstring ("");
1061 MYSTRING *mode_string;
1063 int stopat = list_length (args) - 3;
1065 /* do the argument modes */
1066 for ( ; args != NULL_TREE;
1067 args = TREE_CHAIN (args), count++)
1069 tree argmode = TREE_VALUE (args);
1070 tree attribute = TREE_PURPOSE (args);
1072 if (argmode == void_type_node)
1075 /* if we have exceptions don't process last 2 arguments */
1076 if (TYPE_RAISES_EXCEPTIONS (type) && count == stopat)
1079 if (attribute == ridpointers[(int) RID_LOC])
1080 argmode = TREE_TYPE (argmode);
1081 mode_string = get_type_selective (argmode, all_decls);
1082 if (mode_string->len)
1084 MAYBE_NEWLINE (result);
1085 APPEND (result, mode_string->str);
1092 tree retn_type = TREE_TYPE (type);
1094 if (retn_type != NULL_TREE
1095 && TREE_CODE (retn_type) != VOID_TYPE)
1097 mode_string = get_type_selective (retn_type, all_decls);
1098 if (mode_string->len)
1100 MAYBE_NEWLINE (result);
1101 APPEND (result, mode_string->str);
1110 /* output a mode (or type). */
1116 MYSTRING *result = newstring ("");
1117 MYSTRING *mode_string;
1119 switch ((enum chill_tree_code)TREE_CODE (type))
1122 if (DECL_NAME (type))
1124 APPEND (result, IDENTIFIER_POINTER (DECL_NAME (type)));
1127 type = TREE_TYPE (type);
1130 case IDENTIFIER_NODE:
1131 APPEND (result, IDENTIFIER_POINTER (type));
1135 /* LANG_TYPE are only used until satisfy is done,
1136 as place-holders for 'READ T', NEWMODE/SYNMODE modes,
1137 parameterised modes, and old-fashioned CHAR(N). */
1138 if (TYPE_READONLY (type))
1139 APPEND (result, "READ ");
1141 mode_string = get_type (TREE_TYPE (type));
1142 APPEND (result, mode_string->str);
1143 if (TYPE_DOMAIN (type) != NULL_TREE)
1145 /* Parameterized mode,
1146 or old-fashioned CHAR(N) string declaration.. */
1147 APPEND (result, "(");
1148 mode_string = decode_constant (TYPE_DOMAIN (type));
1149 APPEND (result, mode_string->str);
1150 APPEND (result, ")");
1156 mode_string = grant_array_type (type);
1157 APPEND (result, mode_string->str);
1162 APPEND (result, "BOOL");
1166 APPEND (result, "CHAR");
1170 mode_string = print_enumeral (type);
1171 APPEND (result, mode_string->str);
1177 tree args = TYPE_ARG_TYPES (type);
1179 APPEND (result, "PROC (");
1181 mode_string = print_proc_tail (type, args, 0);
1182 APPEND (result, mode_string->str);
1188 mode_string = print_integer_type (type);
1189 APPEND (result, mode_string->str);
1194 if (CH_IS_INSTANCE_MODE (type))
1196 APPEND (result, "INSTANCE");
1199 else if (CH_IS_BUFFER_MODE (type) || CH_IS_EVENT_MODE (type))
1200 { tree bufsize = max_queue_size (type);
1201 APPEND (result, CH_IS_BUFFER_MODE (type) ? "BUFFER " : "EVENT ");
1202 if (bufsize != NULL_TREE)
1204 APPEND (result, "(");
1205 mode_string = decode_constant (bufsize);
1206 APPEND (result, mode_string->str);
1207 APPEND (result, ") ");
1210 if (CH_IS_BUFFER_MODE (type))
1212 mode_string = decode_mode (buffer_element_mode (type));
1213 APPEND (result, mode_string->str);
1218 else if (CH_IS_ACCESS_MODE (type))
1220 tree indexmode, recordmode, dynamic;
1222 APPEND (result, "ACCESS");
1223 recordmode = access_recordmode (type);
1224 indexmode = access_indexmode (type);
1225 dynamic = access_dynamic (type);
1227 if (indexmode != void_type_node)
1229 mode_string = decode_mode (indexmode);
1230 APPEND (result, " (");
1231 APPEND (result, mode_string->str);
1232 APPEND (result, ")");
1235 if (recordmode != void_type_node)
1237 mode_string = decode_mode (recordmode);
1238 APPEND (result, " ");
1239 APPEND (result, mode_string->str);
1242 if (dynamic != integer_zero_node)
1243 APPEND (result, " DYNAMIC");
1246 else if (CH_IS_TEXT_MODE (type))
1248 tree indexmode, dynamic, length;
1250 APPEND (result, "TEXT (");
1251 length = text_length (type);
1252 indexmode = text_indexmode (type);
1253 dynamic = text_dynamic (type);
1255 mode_string = decode_constant (length);
1256 APPEND (result, mode_string->str);
1258 APPEND (result, ")");
1259 if (indexmode != void_type_node)
1261 APPEND (result, " ");
1262 mode_string = decode_mode (indexmode);
1263 APPEND (result, mode_string->str);
1266 if (dynamic != integer_zero_node)
1267 APPEND (result, " DYNAMIC");
1270 mode_string = print_struct (type);
1271 APPEND (result, mode_string->str);
1276 if (TREE_CODE (TREE_TYPE (type)) == VOID_TYPE)
1277 APPEND (result, "PTR");
1280 if (TREE_CODE (TREE_TYPE (type)) == FUNCTION_TYPE)
1282 mode_string = get_type (TREE_TYPE (type));
1283 APPEND (result, mode_string->str);
1288 APPEND (result, "REF ");
1289 mode_string = get_type (TREE_TYPE (type));
1290 APPEND (result, mode_string->str);
1297 if (TREE_INT_CST_LOW (TYPE_SIZE (type)) == 32)
1298 APPEND (result, "REAL");
1300 APPEND (result, "LONG_REAL");
1304 if (CH_BOOLS_TYPE_P (type))
1305 mode_string = grant_array_type (type);
1308 APPEND (result, "POWERSET ");
1309 mode_string = get_type (TYPE_DOMAIN (type));
1311 APPEND (result, mode_string->str);
1315 case REFERENCE_TYPE:
1316 mode_string = get_type (TREE_TYPE (type));
1317 APPEND (result, mode_string->str);
1322 APPEND (result, "/* ---- not implemented ---- */");
1330 find_in_decls (id, all_decls)
1336 for (wrk = all_decls; wrk != NULL_TREE; wrk = TREE_CHAIN (wrk))
1338 if (DECL_NAME (wrk) == id || DECL_POSTFIX (wrk) == id)
1349 for (i = RID_UNUSED; i < RID_MAX; i++)
1351 if (id == ridpointers[i])
1358 grant_seized_identifier (decl)
1361 seizefile_list *wrk = selective_seizes;
1362 MYSTRING *mode_string;
1364 CH_ALREADY_GRANTED (decl) = 1;
1366 /* comes from a SPEC MODULE in the module */
1367 if (DECL_SEIZEFILE (decl) == NULL_TREE)
1370 /* search file already in process */
1373 if (wrk->filename == DECL_SEIZEFILE (decl))
1379 wrk = (seizefile_list *)xmalloc (sizeof (seizefile_list));
1380 wrk->next = selective_seizes;
1381 selective_seizes = wrk;
1382 wrk->filename = DECL_SEIZEFILE (decl);
1383 wrk->seizes = newstring ("<> USE_SEIZE_FILE \"");
1384 APPEND (wrk->seizes, IDENTIFIER_POINTER (DECL_SEIZEFILE (decl)));
1385 APPEND (wrk->seizes, "\" <>\n");
1387 APPEND (wrk->seizes, "SEIZE ");
1388 mode_string = decode_prefix_rename (decl);
1389 APPEND (wrk->seizes, mode_string->str);
1391 APPEND (wrk->seizes, ";\n");
1395 decode_mode_selective (type, all_decls)
1399 MYSTRING *result = newstring ("");
1400 MYSTRING *mode_string;
1403 switch ((enum chill_tree_code)TREE_CODE (type))
1406 /* FIXME: could this ever happen ?? */
1407 if (DECL_NAME (type))
1410 result = decode_mode_selective (DECL_NAME (type), all_decls);
1415 case IDENTIFIER_NODE:
1416 if (in_ridpointers (type))
1417 /* it's a predefined, we must not search the whole list */
1420 decl = find_in_decls (type, all_decls);
1421 if (decl != NULL_TREE)
1423 if (CH_ALREADY_GRANTED (decl))
1424 /* already processed */
1427 if (TREE_CODE (decl) == ALIAS_DECL && DECL_POSTFIX (decl) != NULL_TREE)
1429 /* If CH_DECL_GRANTED, decl was granted into this scope, and
1430 so wasn't in the source code. */
1431 if (!CH_DECL_GRANTED (decl))
1433 grant_seized_identifier (decl);
1438 result = decode_decl (decl);
1439 mode_string = decode_decl_selective (decl, all_decls);
1440 if (mode_string->len)
1442 PREPEND (result, mode_string->str);
1450 mode_string = get_type_selective (TREE_TYPE (type), all_decls);
1451 APPEND (result, mode_string->str);
1456 mode_string = grant_array_type_selective (type, all_decls);
1457 APPEND (result, mode_string->str);
1470 mode_string = print_enumeral_selective (type, all_decls);
1471 if (mode_string->len)
1472 APPEND (result, mode_string->str);
1478 tree args = TYPE_ARG_TYPES (type);
1480 mode_string = print_proc_tail_selective (type, args, all_decls);
1481 if (mode_string->len)
1482 APPEND (result, mode_string->str);
1488 mode_string = print_integer_selective (type, all_decls);
1489 if (mode_string->len)
1490 APPEND (result, mode_string->str);
1495 if (CH_IS_INSTANCE_MODE (type))
1499 else if (CH_IS_BUFFER_MODE (type) || CH_IS_EVENT_MODE (type))
1501 tree bufsize = max_queue_size (type);
1502 if (bufsize != NULL_TREE)
1504 mode_string = decode_constant_selective (bufsize, all_decls);
1505 if (mode_string->len)
1506 APPEND (result, mode_string->str);
1509 if (CH_IS_BUFFER_MODE (type))
1511 mode_string = decode_mode_selective (buffer_element_mode (type), all_decls);
1512 if (mode_string->len)
1514 MAYBE_NEWLINE (result);
1515 APPEND (result, mode_string->str);
1521 else if (CH_IS_ACCESS_MODE (type))
1523 tree indexmode = access_indexmode (type);
1524 tree recordmode = access_recordmode (type);
1526 if (indexmode != void_type_node)
1528 mode_string = decode_mode_selective (indexmode, all_decls);
1529 if (mode_string->len)
1531 if (result->len && result->str[result->len - 1] != '\n')
1532 APPEND (result, ";\n");
1533 APPEND (result, mode_string->str);
1537 if (recordmode != void_type_node)
1539 mode_string = decode_mode_selective (recordmode, all_decls);
1540 if (mode_string->len)
1542 if (result->len && result->str[result->len - 1] != '\n')
1543 APPEND (result, ";\n");
1544 APPEND (result, mode_string->str);
1550 else if (CH_IS_TEXT_MODE (type))
1552 tree indexmode = text_indexmode (type);
1553 tree length = text_length (type);
1555 mode_string = decode_constant_selective (length, all_decls);
1556 if (mode_string->len)
1557 APPEND (result, mode_string->str);
1559 if (indexmode != void_type_node)
1561 mode_string = decode_mode_selective (indexmode, all_decls);
1562 if (mode_string->len)
1564 if (result->len && result->str[result->len - 1] != '\n')
1565 APPEND (result, ";\n");
1566 APPEND (result, mode_string->str);
1572 mode_string = print_struct_selective (type, all_decls);
1573 if (mode_string->len)
1575 MAYBE_NEWLINE (result);
1576 APPEND (result, mode_string->str);
1582 if (TREE_CODE (TREE_TYPE (type)) == VOID_TYPE)
1586 if (TREE_CODE (TREE_TYPE (type)) == FUNCTION_TYPE)
1588 mode_string = get_type_selective (TREE_TYPE (type), all_decls);
1589 if (mode_string->len)
1590 APPEND (result, mode_string->str);
1595 mode_string = get_type_selective (TREE_TYPE (type), all_decls);
1596 if (mode_string->len)
1597 APPEND (result, mode_string->str);
1608 if (CH_BOOLS_TYPE_P (type))
1609 mode_string = grant_array_type_selective (type, all_decls);
1611 mode_string = get_type_selective (TYPE_DOMAIN (type), all_decls);
1612 if (mode_string->len)
1613 APPEND (result, mode_string->str);
1617 case REFERENCE_TYPE:
1618 mode_string = get_type_selective (TREE_TYPE (type), all_decls);
1619 if (mode_string->len)
1620 APPEND (result, mode_string->str);
1625 APPEND (result, "/* ---- not implemented ---- */");
1636 if (type == NULL_TREE || TREE_CODE (type) == ERROR_MARK)
1637 return newstring ("");
1639 return (decode_mode (type));
1643 get_type_selective (type, all_decls)
1647 if (type == NULL_TREE || TREE_CODE (type) == ERROR_MARK)
1648 return newstring ("");
1650 return (decode_mode_selective (type, all_decls));
1655 is_forbidden (str, forbid)
1659 if (forbid == NULL_TREE)
1662 if (TREE_CODE (forbid) == INTEGER_CST)
1665 while (forbid != NULL_TREE)
1667 if (TREE_VALUE (forbid) == str)
1669 forbid = TREE_CHAIN (forbid);
1677 decode_constant (init)
1680 MYSTRING *result = newstring ("");
1681 MYSTRING *tmp_string;
1682 tree type = TREE_TYPE (init);
1686 MYSTRING *mode_string;
1688 switch ((enum chill_tree_code)TREE_CODE (val))
1691 tmp_string = decode_constant (TREE_OPERAND (val, 0));
1692 APPEND (result, tmp_string->str);
1694 val = TREE_OPERAND (val, 1); /* argument list */
1695 if (val != NULL_TREE && TREE_CODE (val) != TREE_LIST)
1697 APPEND (result, " ");
1698 tmp_string = decode_constant (val);
1699 APPEND (result, tmp_string->str);
1704 APPEND (result, " (");
1705 if (val != NULL_TREE)
1709 tmp_string = decode_constant (TREE_VALUE (val));
1710 APPEND (result, tmp_string->str);
1712 val = TREE_CHAIN (val);
1713 if (val == NULL_TREE)
1715 APPEND (result, ", ");
1718 APPEND (result, ")");
1723 /* Generate an "expression conversion" expression (a cast). */
1724 tmp_string = decode_mode (type);
1726 APPEND (result, tmp_string->str);
1728 APPEND (result, "(");
1729 val = TREE_OPERAND (val, 0);
1730 type = TREE_TYPE (val);
1732 /* If the coercee is a tuple, make sure it is prefixed by its mode. */
1733 if (TREE_CODE (val) == CONSTRUCTOR
1734 && !CH_BOOLS_TYPE_P (type) && !chill_varying_type_p (type))
1736 tmp_string = decode_mode (type);
1737 APPEND (result, tmp_string->str);
1739 APPEND (result, " ");
1742 tmp_string = decode_constant (val);
1743 APPEND (result, tmp_string->str);
1745 APPEND (result, ")");
1748 case IDENTIFIER_NODE:
1749 APPEND (result, IDENTIFIER_POINTER (val));
1753 APPEND (result, "(");
1754 tmp_string = decode_constant (TREE_OPERAND (val, 0));
1755 APPEND (result, tmp_string->str);
1757 APPEND (result, ")");
1760 case UNDEFINED_EXPR:
1761 APPEND (result, "*");
1764 case PLUS_EXPR: op = "+"; goto binary;
1765 case MINUS_EXPR: op = "-"; goto binary;
1766 case MULT_EXPR: op = "*"; goto binary;
1767 case TRUNC_DIV_EXPR: op = "/"; goto binary;
1768 case FLOOR_MOD_EXPR: op = " MOD "; goto binary;
1769 case TRUNC_MOD_EXPR: op = " REM "; goto binary;
1770 case CONCAT_EXPR: op = "//"; goto binary;
1771 case BIT_IOR_EXPR: op = " OR "; goto binary;
1772 case BIT_XOR_EXPR: op = " XOR "; goto binary;
1773 case TRUTH_ORIF_EXPR: op = " ORIF "; goto binary;
1774 case BIT_AND_EXPR: op = " AND "; goto binary;
1775 case TRUTH_ANDIF_EXPR: op = " ANDIF "; goto binary;
1776 case GT_EXPR: op = ">"; goto binary;
1777 case GE_EXPR: op = ">="; goto binary;
1778 case SET_IN_EXPR: op = " IN "; goto binary;
1779 case LT_EXPR: op = "<"; goto binary;
1780 case LE_EXPR: op = "<="; goto binary;
1781 case EQ_EXPR: op = "="; goto binary;
1782 case NE_EXPR: op = "/="; goto binary;
1784 if (TREE_OPERAND (val, 0) == NULL_TREE)
1786 APPEND (result, TREE_OPERAND (val, 1) == NULL_TREE ? "*" : "ELSE");
1789 op = ":"; goto binary;
1791 tmp_string = decode_constant (TREE_OPERAND (val, 0));
1792 APPEND (result, tmp_string->str);
1794 APPEND (result, op);
1795 tmp_string = decode_constant (TREE_OPERAND (val, 1));
1796 APPEND (result, tmp_string->str);
1800 case REPLICATE_EXPR:
1801 APPEND (result, "(");
1802 tmp_string = decode_constant (TREE_OPERAND (val, 0));
1803 APPEND (result, tmp_string->str);
1805 APPEND (result, ")");
1806 tmp_string = decode_constant (TREE_OPERAND (val, 1));
1807 APPEND (result, tmp_string->str);
1811 case NEGATE_EXPR: op = "-"; goto unary;
1812 case BIT_NOT_EXPR: op = " NOT "; goto unary;
1813 case ADDR_EXPR: op = "->"; goto unary;
1815 APPEND (result, op);
1816 tmp_string = decode_constant (TREE_OPERAND (val, 0));
1817 APPEND (result, tmp_string->str);
1822 APPEND (result, display_int_cst (val));
1826 #ifndef REAL_IS_NOT_DOUBLE
1827 sprintf (wrk, "%.20g", TREE_REAL_CST (val));
1829 REAL_VALUE_TO_DECIMAL (TREE_REAL_CST (val), "%.20g", wrk);
1831 APPEND (result, wrk);
1836 char *ptr = TREE_STRING_POINTER (val);
1837 int i = TREE_STRING_LENGTH (val);
1838 APPEND (result, "\"");
1842 unsigned char c = *ptr++;
1844 APPEND (result, "^^");
1846 APPEND (result, "\"\"");
1848 APPEND (result, "^J");
1849 else if (c < ' ' || c > '~')
1851 sprintf (buf, "^(%u)", c);
1852 APPEND (result, buf);
1858 APPEND (result, buf);
1861 APPEND (result, "\"");
1866 val = TREE_OPERAND (val, 1);
1867 if (type != NULL && TREE_CODE (type) == SET_TYPE
1868 && CH_BOOLS_TYPE_P (type))
1870 /* It's a bitstring. */
1871 tree domain = TYPE_DOMAIN (type);
1872 tree domain_max = TYPE_MAX_VALUE (domain);
1876 if (TREE_CODE (domain_max) != INTEGER_CST
1877 || (val && TREE_CODE (val) != TREE_LIST))
1880 len = TREE_INT_CST_LOW (domain_max) + 1;
1881 if (TREE_CODE (init) != CONSTRUCTOR)
1883 buf = (char *) alloca (len + 10);
1888 if (get_set_constructor_bits (init, ptr, len))
1890 for (; --len >= 0; ptr++)
1894 APPEND (result, buf);
1898 { /* It's some kind of tuple */
1899 if (type != NULL_TREE)
1901 mode_string = get_type (type);
1902 APPEND (result, mode_string->str);
1904 APPEND (result, " ");
1906 if (val == NULL_TREE
1907 || TREE_CODE (val) == ERROR_MARK)
1908 APPEND (result, "[ ]");
1909 else if (TREE_CODE (val) != TREE_LIST)
1913 APPEND (result, "[");
1916 tree lo_val = TREE_PURPOSE (val);
1917 tree hi_val = TREE_VALUE (val);
1918 MYSTRING *val_string;
1919 if (TUPLE_NAMED_FIELD (val))
1920 APPEND(result, ".");
1921 if (lo_val != NULL_TREE)
1923 val_string = decode_constant (lo_val);
1924 APPEND (result, val_string->str);
1926 APPEND (result, ":");
1928 val_string = decode_constant (hi_val);
1929 APPEND (result, val_string->str);
1931 val = TREE_CHAIN (val);
1932 if (val == NULL_TREE)
1934 APPEND (result, ", ");
1936 APPEND (result, "]");
1944 mode_string = decode_constant (TREE_OPERAND (init, 0));
1945 APPEND (result, mode_string->str);
1947 op1 = TREE_OPERAND (init, 1);
1948 if (TREE_CODE (op1) != IDENTIFIER_NODE)
1950 error ("decode_constant: invalid component_ref");
1953 APPEND (result, ".");
1954 APPEND (result, IDENTIFIER_POINTER (op1));
1958 error ("decode_constant: mode and value mismatch");
1961 error ("decode_constant: cannot decode this mode");
1968 decode_constant_selective (init, all_decls)
1972 MYSTRING *result = newstring ("");
1973 MYSTRING *tmp_string;
1974 tree type = TREE_TYPE (init);
1976 MYSTRING *mode_string;
1978 switch ((enum chill_tree_code)TREE_CODE (val))
1981 tmp_string = decode_constant_selective (TREE_OPERAND (val, 0), all_decls);
1982 if (tmp_string->len)
1983 APPEND (result, tmp_string->str);
1985 val = TREE_OPERAND (val, 1); /* argument list */
1986 if (val != NULL_TREE && TREE_CODE (val) != TREE_LIST)
1988 tmp_string = decode_constant_selective (val, all_decls);
1989 if (tmp_string->len)
1991 MAYBE_NEWLINE (result);
1992 APPEND (result, tmp_string->str);
1998 if (val != NULL_TREE)
2002 tmp_string = decode_constant_selective (TREE_VALUE (val), all_decls);
2003 if (tmp_string->len)
2005 MAYBE_NEWLINE (result);
2006 APPEND (result, tmp_string->str);
2009 val = TREE_CHAIN (val);
2010 if (val == NULL_TREE)
2018 /* Generate an "expression conversion" expression (a cast). */
2019 tmp_string = decode_mode_selective (type, all_decls);
2020 if (tmp_string->len)
2021 APPEND (result, tmp_string->str);
2023 val = TREE_OPERAND (val, 0);
2024 type = TREE_TYPE (val);
2026 /* If the coercee is a tuple, make sure it is prefixed by its mode. */
2027 if (TREE_CODE (val) == CONSTRUCTOR
2028 && !CH_BOOLS_TYPE_P (type) && !chill_varying_type_p (type))
2030 tmp_string = decode_mode_selective (type, all_decls);
2031 if (tmp_string->len)
2032 APPEND (result, tmp_string->str);
2036 tmp_string = decode_constant_selective (val, all_decls);
2037 if (tmp_string->len)
2038 APPEND (result, tmp_string->str);
2042 case IDENTIFIER_NODE:
2043 tmp_string = decode_mode_selective (val, all_decls);
2044 if (tmp_string->len)
2045 APPEND (result, tmp_string->str);
2050 tmp_string = decode_constant_selective (TREE_OPERAND (val, 0), all_decls);
2051 if (tmp_string->len)
2052 APPEND (result, tmp_string->str);
2056 case UNDEFINED_EXPR:
2062 case TRUNC_DIV_EXPR:
2063 case FLOOR_MOD_EXPR:
2064 case TRUNC_MOD_EXPR:
2068 case TRUTH_ORIF_EXPR:
2070 case TRUTH_ANDIF_EXPR:
2080 if (TREE_OPERAND (val, 0) == NULL_TREE)
2084 tmp_string = decode_constant_selective (TREE_OPERAND (val, 0), all_decls);
2085 if (tmp_string->len)
2086 APPEND (result, tmp_string->str);
2088 tmp_string = decode_constant_selective (TREE_OPERAND (val, 1), all_decls);
2089 if (tmp_string->len)
2091 MAYBE_NEWLINE (result);
2092 APPEND (result, tmp_string->str);
2097 case REPLICATE_EXPR:
2098 tmp_string = decode_constant_selective (TREE_OPERAND (val, 0), all_decls);
2099 if (tmp_string->len)
2100 APPEND (result, tmp_string->str);
2102 tmp_string = decode_constant_selective (TREE_OPERAND (val, 1), all_decls);
2103 if (tmp_string->len)
2105 MAYBE_NEWLINE (result);
2106 APPEND (result, tmp_string->str);
2114 tmp_string = decode_constant_selective (TREE_OPERAND (val, 0), all_decls);
2115 if (tmp_string->len)
2116 APPEND (result, tmp_string->str);
2130 val = TREE_OPERAND (val, 1);
2131 if (type != NULL && TREE_CODE (type) == SET_TYPE
2132 && CH_BOOLS_TYPE_P (type))
2133 /* It's a bitstring. */
2136 { /* It's some kind of tuple */
2137 if (type != NULL_TREE)
2139 mode_string = get_type_selective (type, all_decls);
2140 if (mode_string->len)
2141 APPEND (result, mode_string->str);
2144 if (val == NULL_TREE
2145 || TREE_CODE (val) == ERROR_MARK)
2147 else if (TREE_CODE (val) != TREE_LIST)
2153 tree lo_val = TREE_PURPOSE (val);
2154 tree hi_val = TREE_VALUE (val);
2155 MYSTRING *val_string;
2156 if (lo_val != NULL_TREE)
2158 val_string = decode_constant_selective (lo_val, all_decls);
2159 if (val_string->len)
2160 APPEND (result, val_string->str);
2163 val_string = decode_constant_selective (hi_val, all_decls);
2164 if (val_string->len)
2166 MAYBE_NEWLINE (result);
2167 APPEND (result, val_string->str);
2170 val = TREE_CHAIN (val);
2171 if (val == NULL_TREE)
2179 mode_string = decode_constant_selective (TREE_OPERAND (init, 0), all_decls);
2180 if (mode_string->len)
2181 APPEND (result, mode_string->str);
2186 error ("decode_constant_selective: mode and value mismatch");
2189 error ("decode_constant_selective: cannot decode this mode");
2195 /* Assuming DECL is an ALIAS_DECL, return its prefix rename clause. */
2198 decode_prefix_rename (decl)
2201 MYSTRING *result = newstring ("");
2202 if (DECL_OLD_PREFIX (decl) || DECL_NEW_PREFIX (decl))
2204 APPEND (result, "(");
2205 if (DECL_OLD_PREFIX (decl))
2206 APPEND (result, IDENTIFIER_POINTER (DECL_OLD_PREFIX (decl)));
2207 APPEND (result, "->");
2208 if (DECL_NEW_PREFIX (decl))
2209 APPEND (result, IDENTIFIER_POINTER (DECL_NEW_PREFIX (decl)));
2210 APPEND (result, ")!");
2212 if (DECL_POSTFIX_ALL (decl))
2213 APPEND (result, "ALL");
2215 APPEND (result, IDENTIFIER_POINTER (DECL_POSTFIX (decl)));
2223 MYSTRING *result = newstring ("");
2224 MYSTRING *mode_string;
2227 switch ((enum chill_tree_code)TREE_CODE (decl))
2231 APPEND (result, "DCL ");
2232 APPEND (result, IDENTIFIER_POINTER (DECL_NAME (decl)));
2233 APPEND (result, " ");
2234 mode_string = get_type (TREE_TYPE (decl));
2235 APPEND (result, mode_string->str);
2237 if ((enum chill_tree_code)TREE_CODE (decl) == BASED_DECL)
2239 APPEND (result, " BASED (");
2240 APPEND (result, IDENTIFIER_POINTER (DECL_ABSTRACT_ORIGIN (decl)));
2241 APPEND (result, ")");
2246 if (CH_DECL_SIGNAL (decl))
2248 /* this is really a signal */
2249 tree fields = TYPE_FIELDS (TREE_TYPE (decl));
2250 tree signame = DECL_NAME (decl);
2253 APPEND (result, "SIGNAL ");
2254 APPEND (result, IDENTIFIER_POINTER (signame));
2255 if (IDENTIFIER_SIGNAL_DATA (signame))
2257 APPEND (result, " = (");
2258 for ( ; fields != NULL_TREE;
2259 fields = TREE_CHAIN (fields))
2261 MYSTRING *mode_string;
2263 mode_string = get_type (TREE_TYPE (fields));
2264 APPEND (result, mode_string->str);
2266 if (TREE_CHAIN (fields) != NULL_TREE)
2267 APPEND (result, ", ");
2269 APPEND (result, ")");
2271 sigdest = IDENTIFIER_SIGNAL_DEST (signame);
2272 if (sigdest != NULL_TREE)
2274 APPEND (result, " TO ");
2275 APPEND (result, IDENTIFIER_POINTER (DECL_NAME (sigdest)));
2280 /* avoid defining a mode as itself */
2281 if (CH_NOVELTY (TREE_TYPE (decl)) == decl)
2282 APPEND (result, "NEWMODE ");
2284 APPEND (result, "SYNMODE ");
2285 APPEND (result, IDENTIFIER_POINTER (DECL_NAME (decl)));
2286 APPEND (result, " = ");
2287 mode_string = decode_mode (TREE_TYPE (decl));
2288 APPEND (result, mode_string->str);
2297 type = TREE_TYPE (decl);
2298 args = TYPE_ARG_TYPES (type);
2300 APPEND (result, IDENTIFIER_POINTER (DECL_NAME (decl)));
2302 if (CH_DECL_PROCESS (decl))
2303 APPEND (result, ": PROCESS (");
2305 APPEND (result, ": PROC (");
2307 args = TYPE_ARG_TYPES (type);
2309 mode_string = print_proc_tail (type, args, 1);
2310 APPEND (result, mode_string->str);
2314 if (CH_DECL_GENERAL (decl))
2315 APPEND (result, " GENERAL");
2316 if (CH_DECL_SIMPLE (decl))
2317 APPEND (result, " SIMPLE");
2318 if (DECL_INLINE (decl))
2319 APPEND (result, " INLINE");
2320 if (CH_DECL_RECURSIVE (decl))
2321 APPEND (result, " RECURSIVE");
2322 APPEND (result, " END");
2327 APPEND (result, IDENTIFIER_POINTER (DECL_NAME (decl)));
2328 APPEND (result, " ");
2329 mode_string = get_type (TREE_TYPE (decl));
2330 APPEND (result, mode_string->str);
2332 if (DECL_INITIAL (decl) != NULL_TREE)
2334 mode_string = decode_layout (DECL_INITIAL (decl));
2335 APPEND (result, mode_string->str);
2339 if (is_forbidden (DECL_NAME (decl), forbid))
2340 APPEND (result, " FORBID");
2345 if (DECL_INITIAL (decl) == NULL_TREE
2346 || TREE_CODE (DECL_INITIAL (decl)) == ERROR_MARK)
2348 APPEND (result, "SYN ");
2349 APPEND (result, IDENTIFIER_POINTER (DECL_NAME (decl)));
2350 APPEND (result, " ");
2351 mode_string = get_type (TREE_TYPE (decl));
2352 APPEND (result, mode_string->str);
2354 APPEND (result, " = ");
2355 mode_string = decode_constant (DECL_INITIAL (decl));
2356 APPEND (result, mode_string->str);
2361 /* If CH_DECL_GRANTED, decl was granted into this scope, and
2362 so wasn't in the source code. */
2363 if (!CH_DECL_GRANTED (decl))
2365 static int restricted = 0;
2367 if (DECL_SEIZEFILE (decl) != use_seizefile_name
2368 && DECL_SEIZEFILE (decl))
2370 use_seizefile_name = DECL_SEIZEFILE (decl);
2371 restricted = use_seizefile_name == NULL_TREE ? 0 : CH_USE_SEIZEFILE_RESTRICTED (use_seizefile_name);
2373 grant_use_seizefile (IDENTIFIER_POINTER (use_seizefile_name));
2374 mark_use_seizefile_written (use_seizefile_name);
2378 APPEND (result, "SEIZE ");
2379 mode_string = decode_prefix_rename (decl);
2380 APPEND (result, mode_string->str);
2387 APPEND (result, "----- not implemented ------");
2394 decode_decl_selective (decl, all_decls)
2398 MYSTRING *result = newstring ("");
2399 MYSTRING *mode_string;
2402 if (CH_ALREADY_GRANTED (decl))
2406 CH_ALREADY_GRANTED (decl) = 1;
2408 switch ((enum chill_tree_code)TREE_CODE (decl))
2412 mode_string = get_type_selective (TREE_TYPE (decl), all_decls);
2413 if (mode_string->len)
2414 APPEND (result, mode_string->str);
2416 if ((enum chill_tree_code)TREE_CODE (decl) == BASED_DECL)
2418 mode_string = decode_mode_selective (DECL_ABSTRACT_ORIGIN (decl), all_decls);
2419 if (mode_string->len)
2420 PREPEND (result, mode_string->str);
2426 if (CH_DECL_SIGNAL (decl))
2428 /* this is really a signal */
2429 tree fields = TYPE_FIELDS (TREE_TYPE (decl));
2430 tree signame = DECL_NAME (decl);
2433 if (IDENTIFIER_SIGNAL_DATA (signame))
2435 for ( ; fields != NULL_TREE;
2436 fields = TREE_CHAIN (fields))
2438 MYSTRING *mode_string;
2440 mode_string = get_type_selective (TREE_TYPE (fields),
2442 if (mode_string->len)
2443 APPEND (result, mode_string->str);
2447 sigdest = IDENTIFIER_SIGNAL_DEST (signame);
2448 if (sigdest != NULL_TREE)
2450 mode_string = decode_mode_selective (DECL_NAME (sigdest), all_decls);
2451 if (mode_string->len)
2453 MAYBE_NEWLINE (result);
2454 APPEND (result, mode_string->str);
2461 /* avoid defining a mode as itself */
2462 mode_string = decode_mode_selective (TREE_TYPE (decl), all_decls);
2463 APPEND (result, mode_string->str);
2472 type = TREE_TYPE (decl);
2473 args = TYPE_ARG_TYPES (type);
2475 args = TYPE_ARG_TYPES (type);
2477 mode_string = print_proc_tail_selective (type, args, all_decls);
2478 if (mode_string->len)
2479 APPEND (result, mode_string->str);
2485 mode_string = get_type_selective (TREE_TYPE (decl), all_decls);
2486 if (mode_string->len)
2487 APPEND (result, mode_string->str);
2492 if (DECL_INITIAL (decl) == NULL_TREE
2493 || TREE_CODE (DECL_INITIAL (decl)) == ERROR_MARK)
2495 mode_string = get_type_selective (TREE_TYPE (decl), all_decls);
2496 if (mode_string->len)
2497 APPEND (result, mode_string->str);
2499 mode_string = decode_constant_selective (DECL_INITIAL (decl), all_decls);
2500 if (mode_string->len)
2502 MAYBE_NEWLINE (result);
2503 APPEND (result, mode_string->str);
2509 MAYBE_NEWLINE (result);
2514 globalize_decl (decl)
2517 if (!TREE_PUBLIC (decl) && DECL_NAME (decl) &&
2518 (TREE_CODE (decl) == VAR_DECL || TREE_CODE (decl) == FUNCTION_DECL))
2520 extern FILE *asm_out_file;
2521 extern char *first_global_object_name;
2522 char *name = XSTR (XEXP (DECL_RTL (decl), 0), 0);
2524 if (!first_global_object_name)
2525 first_global_object_name = name + (name[0] == '*');
2526 ASM_GLOBALIZE_LABEL (asm_out_file, name);
2532 grant_one_decl (decl)
2537 if (DECL_SOURCE_LINE (decl) == 0)
2539 result = decode_decl (decl);
2542 APPEND (result, ";\n");
2543 APPEND (gstring, result->str);
2549 grant_one_decl_selective (decl, all_decls)
2556 tree d = DECL_ABSTRACT_ORIGIN (decl);
2558 if (CH_ALREADY_GRANTED (d))
2562 result = decode_decl (d);
2570 APPEND (result, ";\n");
2572 /* now process all undefined items in the decl */
2573 fixups = decode_decl_selective (d, all_decls);
2576 PREPEND (result, fixups->str);
2580 /* we have finished a decl */
2581 APPEND (selective_gstring, result->str);
2586 compare_memory_file (fname, buf)
2593 /* check if we have something to write */
2594 if (!buf || !strlen (buf))
2597 if ((fb = fopen (fname, "r")) == NULL)
2600 while ((c = getc (fb)) != EOF)
2609 return (*buf ? 1 : 0);
2617 /* We only write out the grant file if it has changed,
2618 to avoid changing its time-stamp and triggering an
2619 unnecessary 'make' action. Return if no change. */
2620 if (gstring == NULL || !spec_module_generated ||
2621 !compare_memory_file (grant_file_name, gstring->str))
2624 fb = fopen (grant_file_name, "w");
2626 pfatal_with_name (grant_file_name);
2628 /* write file. Due to problems with record sizes on VAX/VMS
2629 write string to '\n' */
2631 /* do it this way for VMS, cause of problems with
2636 p1 = strchr (p, '\n');
2639 fprintf (fb, "%s", p);
2644 /* faster way to write */
2645 if (write (fileno (fb), gstring->str, gstring->len) < 0)
2647 int save_errno = errno;
2648 unlink (grant_file_name);
2650 pfatal_with_name (grant_file_name);
2657 /* handle grant statement */
2660 set_default_grant_file ()
2662 char *p, *tmp, *fname;
2665 fname = dump_base_name; /* Probably invoked via gcc */
2667 { /* Probably invoked directly (not via gcc) */
2668 fname = asm_file_name;
2670 fname = main_input_filename ? main_input_filename : input_filename;
2675 p = strrchr (fname, '.');
2678 tmp = (char *) alloca (strlen (fname) + 10);
2679 strcpy (tmp, fname);
2685 tmp = (char *) alloca (i + 10);
2686 strncpy (tmp, fname, i);
2689 strcat (tmp, ".grt");
2690 default_grant_file = build_string (strlen (tmp), tmp);
2692 grant_file_name = TREE_STRING_POINTER (default_grant_file);
2694 if (gstring == NULL)
2695 gstring = newstring ("");
2696 if (selective_gstring == NULL)
2697 selective_gstring = newstring ("");
2700 /* Make DECL visible under the name NAME in the (fake) outermost scope. */
2703 push_granted (name, decl)
2704 tree name ATTRIBUTE_UNUSED, decl ATTRIBUTE_UNUSED;
2707 IDENTIFIER_GRANTED_VALUE (name) = decl;
2708 granted_decls = tree_cons (name, decl, granted_decls);
2713 chill_grant (old_prefix, new_prefix, postfix, forbid)
2722 tree old_name = old_prefix == NULL_TREE ? postfix
2723 : get_identifier3 (IDENTIFIER_POINTER (old_prefix),
2724 "!", IDENTIFIER_POINTER (postfix));
2725 tree new_name = new_prefix == NULL_TREE ? postfix
2726 : get_identifier3 (IDENTIFIER_POINTER (new_prefix),
2727 "!", IDENTIFIER_POINTER (postfix));
2729 tree alias = build_alias_decl (old_prefix, new_prefix, postfix);
2730 CH_DECL_GRANTED (alias) = 1;
2731 DECL_SEIZEFILE (alias) = current_seizefile_name;
2732 TREE_CHAIN (alias) = current_module->granted_decls;
2733 current_module->granted_decls = alias;
2736 warning ("FORBID is not yet implemented"); /* FIXME */
2740 /* flag GRANT ALL only once. Avoids search in case of GRANT ALL. */
2741 static int grant_all_seen = 0;
2743 /* check if a decl is in the list of granted decls. */
2745 search_in_list (name, granted_decls)
2751 for (vars = granted_decls; vars != NULL_TREE; vars = TREE_CHAIN (vars))
2752 if (DECL_SOURCE_LINE (vars))
2754 if (DECL_POSTFIX_ALL (vars))
2759 else if (name == DECL_NAME (vars))
2767 really_grant_this (decl, granted_decls)
2771 /* we never grant labels at module level */
2772 if ((enum chill_tree_code)TREE_CODE (decl) == LABEL_DECL)
2778 switch ((enum chill_tree_code)TREE_CODE (decl))
2783 return search_in_list (DECL_NAME (decl), granted_decls);
2788 if (CH_DECL_SIGNAL (decl))
2789 return search_in_list (DECL_NAME (decl), granted_decls);
2794 /* this nerver should happen */
2795 error_with_decl (decl, "function \"really_grant_this\" called for `%s'.");
2799 /* Write a SPEC MODULE using the declarations in the list DECLS. */
2800 static int header_written = 0;
2801 static char *header_template =
2802 "--\n-- WARNING: this file was generated by\n\
2803 -- GNUCHILL version %s\n-- based on gcc version %s\n--\n";
2806 write_spec_module (decls, granted_decls)
2813 if (granted_decls == NULL_TREE)
2816 use_seizefile_name = NULL_TREE;
2818 if (!header_written)
2820 hdr = (char*) alloca (strlen (gnuchill_version)
2821 + strlen (version_string)
2822 + strlen (header_template) + 1);
2823 sprintf (hdr, header_template, gnuchill_version, version_string);
2824 APPEND (gstring, hdr);
2827 APPEND (gstring, IDENTIFIER_POINTER (current_module->name));
2828 APPEND (gstring, ": SPEC MODULE\n");
2830 /* first of all we look for GRANT ALL specified */
2831 search_in_list (NULL_TREE, granted_decls);
2833 if (grant_all_seen != 0)
2835 /* write all identifiers to grant file */
2836 for (vars = decls; vars != NULL_TREE; vars = TREE_CHAIN (vars))
2838 if (DECL_SOURCE_LINE (vars))
2840 if (DECL_NAME (vars))
2842 if ((TREE_CODE (vars) != CONST_DECL || !CH_DECL_ENUM (vars)) &&
2843 really_grant_this (vars, granted_decls))
2844 grant_one_decl (vars);
2846 else if (DECL_POSTFIX_ALL (vars))
2848 static int restricted = 0;
2850 if (DECL_SEIZEFILE (vars) != use_seizefile_name
2851 && DECL_SEIZEFILE (vars))
2853 use_seizefile_name = DECL_SEIZEFILE (vars);
2854 restricted = use_seizefile_name == NULL_TREE ? 0 : CH_USE_SEIZEFILE_RESTRICTED (use_seizefile_name);
2856 grant_use_seizefile (IDENTIFIER_POINTER (use_seizefile_name));
2857 mark_use_seizefile_written (use_seizefile_name);
2861 APPEND (gstring, "SEIZE ALL;\n");
2869 seizefile_list *wrk, *x;
2871 /* do a selective write to the grantfile. This will reduce the
2872 size of a grantfile and speed up compilation of
2873 modules depending on this grant file */
2875 if (selective_gstring == 0)
2876 selective_gstring = newstring ("");
2878 /* first of all process all SEIZE ALL's */
2879 for (vars = decls; vars != NULL_TREE; vars = TREE_CHAIN (vars))
2881 if (DECL_SOURCE_LINE (vars)
2882 && DECL_POSTFIX_ALL (vars))
2883 grant_seized_identifier (vars);
2886 /* now walk through granted decls */
2887 granted_decls = nreverse (granted_decls);
2888 for (vars = granted_decls; vars != NULL_TREE; vars = TREE_CHAIN (vars))
2890 grant_one_decl_selective (vars, decls);
2892 granted_decls = nreverse (granted_decls);
2894 /* append all SEIZES */
2895 wrk = selective_seizes;
2899 APPEND (gstring, wrk->seizes->str);
2904 selective_seizes = 0;
2906 /* append generated string to grant file */
2907 APPEND (gstring, selective_gstring->str);
2908 FREE (selective_gstring);
2909 selective_gstring = NULL;
2912 for (vars = granted_decls; vars != NULL_TREE; vars = TREE_CHAIN (vars))
2913 if (DECL_SOURCE_LINE (vars))
2915 MYSTRING *mode_string = decode_prefix_rename (vars);
2916 APPEND (gstring, "GRANT ");
2917 APPEND (gstring, mode_string->str);
2919 APPEND (gstring, ";\n");
2922 APPEND (gstring, "END;\n");
2923 spec_module_generated = 1;
2925 /* initialize this for next spec module */
2930 * after the dark comes, after all of the modules are at rest,
2931 * we tuck the compilation unit to bed... A story in pass 1
2932 * and a hug-and-a-kiss goodnight in pass 2.
2935 chill_finish_compile ()
2938 tree chill_init_function;
2941 build_enum_tables ();
2943 /* We only need an initializer function for the source file if
2944 a) there's module-level code to be called, or
2945 b) tasking-related stuff to be initialized. */
2946 if (module_init_list != NULL_TREE || tasking_list != NULL_TREE)
2948 extern tree initializer_type;
2949 static tree chill_init_name;
2951 /* declare the global initializer list */
2952 global_list = do_decl (get_identifier ("_ch_init_list"),
2953 build_chill_pointer_type (initializer_type), 1, 0,
2956 /* Now, we're building the function which is the *real*
2957 constructor - if there's any module-level code in this
2958 source file, the compiler puts the file's initializer entry
2959 onto the global initializer list, so each module's body code
2960 will eventually get called, after all of the processes have
2963 /* This is better done in pass 2 (when first_global_object_name
2964 may have been set), but that is too late.
2965 Perhaps rewrite this so nothing is done in pass 1. */
2968 extern char *first_global_object_name;
2969 /* If we don't do this spoof, we get the name of the first
2970 tasking_code variable, and not the file name. */
2971 char *tmp = first_global_object_name;
2973 first_global_object_name = NULL;
2974 chill_init_name = get_file_function_name ('I');
2975 first_global_object_name = tmp;
2976 /* strip off the file's extension, if any. */
2977 tmp = strrchr (IDENTIFIER_POINTER (chill_init_name), '.');
2982 start_chill_function (chill_init_name, void_type_node, NULL_TREE,
2983 NULL_TREE, NULL_TREE);
2984 TREE_PUBLIC (current_function_decl) = 1;
2985 chill_init_function = current_function_decl;
2987 /* For each module that we've compiled, that had module-level
2988 code to be called, add its entry to the global initializer
2995 for (module_init = module_init_list;
2996 module_init != NULL_TREE;
2997 module_init = TREE_CHAIN (module_init))
2999 tree init_entry = TREE_VALUE (module_init);
3001 /* assign module_entry.next := _ch_init_list; */
3003 build_chill_modify_expr (
3004 build_component_ref (init_entry,
3005 get_identifier ("__INIT_NEXT")),
3008 /* assign _ch_init_list := &module_entry; */
3010 build_chill_modify_expr (global_list,
3011 build1 (ADDR_EXPR, ptr_type_node, init_entry)));
3015 tasking_registry ();
3017 make_decl_rtl (current_function_decl, NULL, 1);
3019 finish_chill_function ();
3023 assemble_constructor (IDENTIFIER_POINTER (chill_init_name));
3024 globalize_decl (chill_init_function);
3027 /* ready now to link decls onto this list in pass 2. */
3028 module_init_list = NULL_TREE;
3029 tasking_list = NULL_TREE;