1 /* Implement I/O-related actions for CHILL.
2 Copyright (C) 1992, 93, 1994, 1998 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, 59 Temple Place - Suite 330,
19 Boston, MA 02111-1307, USA. */
32 /* set non-zero if input text is forced to lowercase */
33 extern int ignore_case;
35 /* set non-zero if special words are to be entered in uppercase */
36 extern int special_UC;
38 static int intsize_of_charsexpr PROTO((tree));
40 /* association mode */
41 tree association_type_node;
42 /* initialzier for association mode */
43 tree association_init_value;
45 /* NOTE: should be same as in runtime/chillrt0.c */
46 #define STDIO_TEXT_LENGTH 1024
47 /* mode of stdout, stdin, stderr*/
48 static tree stdio_type_node;
50 /* usage- and where modes */
54 /* we have to distinguish between io-list-type for WRITETEXT
55 and for READTEXT. WRITETEXT does not process ranges and
56 READTEXT must get pointers to the variables.
58 /* variable to hold the type of the io_list */
59 static tree chill_io_list_type = NULL_TREE;
61 /* the type for the enum tables */
62 static tree enum_table_type = NULL_TREE;
64 /* structure to save enums for later use in compilation */
65 typedef struct save_enum_names
67 struct save_enum_names *forward;
72 static SAVE_ENUM_NAMES *used_enum_names = (SAVE_ENUM_NAMES *)0;
74 typedef struct save_enum_values
77 struct save_enum_names *name;
80 typedef struct save_enums
82 struct save_enums *forward;
87 struct save_enum_values *vals;
90 static SAVE_ENUMS *used_enums = (SAVE_ENUMS *)0;
93 /* Function collects all enums are necessary to collect, makes a copy of
94 the value and returns a VAR_DECL external to current function describing
95 the pointer to a name table, which will be generated at the end of
99 static tree add_enum_to_list (type, context)
104 SAVE_ENUMS *wrk = used_enums;
105 SAVE_ENUM_VALUES *vals;
106 SAVE_ENUM_NAMES *names;
108 while (wrk != (SAVE_ENUMS *)0)
110 /* search for this enum already in use */
111 if (wrk->context == context && wrk->type == type)
113 /* yes, found. look if the ptrdecl is valid in this scope */
114 char *name = IDENTIFIER_POINTER (DECL_NAME (wrk->ptrdecl));
115 tree var = get_identifier (name);
116 tree decl = lookup_name (var);
118 if (decl == NULL_TREE)
120 /* no, not valid in this context, declare it */
121 decl = decl_temp1 (var, build_pointer_type (TREE_TYPE (enum_table_type)),
131 /* not yet found -- generate an entry */
132 wrk = (SAVE_ENUMS *)xmalloc (sizeof (SAVE_ENUMS));
133 wrk->forward = used_enums;
136 /* generate the pointer decl */
137 wrk->ptrdecl = get_unique_identifier ("ENUMTABPTR");
138 wrk->ptrdecl = decl_temp1 (wrk->ptrdecl, build_pointer_type (TREE_TYPE (enum_table_type)),
141 /* save information for later use */
142 wrk->context = context;
145 /* insert the names and values */
146 tmp = TYPE_FIELDS (type);
147 wrk->num_vals = list_length (tmp);
148 vals = (SAVE_ENUM_VALUES *)xmalloc (sizeof (SAVE_ENUM_VALUES) * wrk->num_vals);
151 while (tmp != NULL_TREE)
153 /* search if name is already in use */
154 names = used_enum_names;
155 while (names != (SAVE_ENUM_NAMES *)0)
157 if (names->name == TREE_PURPOSE (tmp))
159 names = names->forward;
161 if (names == (SAVE_ENUM_NAMES *)0)
163 /* we have to insert one */
164 names = (SAVE_ENUM_NAMES *)xmalloc (sizeof (SAVE_ENUM_NAMES));
165 names->forward = used_enum_names;
166 used_enum_names = names;
167 names->decl = NULL_TREE;
168 names->name = TREE_PURPOSE (tmp);
171 vals->val = TREE_INT_CST_LOW (TREE_VALUE (tmp));
173 /* next entry in enum */
175 tmp = TREE_CHAIN (tmp);
178 /* return the generated decl */
184 build_chill_io_list_type ()
186 tree list = NULL_TREE;
187 tree result, enum1, listbase;
190 tree forcharstring, forset_W, forset_R, forboolrange;
192 tree forintrange, intunion, forsetrange, forcharrange;
193 tree long_type, ulong_type, union_type;
195 long_type = long_integer_type_node;
196 ulong_type = long_unsigned_type_node;
198 if (chill_io_list_type != NULL_TREE)
202 /* first build the enum for the desriptor */
203 enum1 = start_enum (NULL_TREE);
204 result = build_enumerator (get_identifier ("__IO_UNUSED"),
206 list = chainon (result, list);
208 result = build_enumerator (get_identifier ("__IO_ByteVal"),
210 list = chainon (result, list);
212 result = build_enumerator (get_identifier ("__IO_UByteVal"),
214 list = chainon (result, list);
216 result = build_enumerator (get_identifier ("__IO_IntVal"),
218 list = chainon (result, list);
220 result = build_enumerator (get_identifier ("__IO_UIntVal"),
222 list = chainon (result, list);
224 result = build_enumerator (get_identifier ("__IO_LongVal"),
226 list = chainon (result, list);
228 result = build_enumerator (get_identifier ("__IO_ULongVal"),
230 list = chainon (result, list);
232 result = build_enumerator (get_identifier ("__IO_ByteLoc"),
234 list = chainon (result, list);
236 result = build_enumerator (get_identifier ("__IO_UByteLoc"),
238 list = chainon (result, list);
240 result = build_enumerator (get_identifier ("__IO_IntLoc"),
242 list = chainon (result, list);
244 result = build_enumerator (get_identifier ("__IO_UIntLoc"),
246 list = chainon (result, list);
248 result = build_enumerator (get_identifier ("__IO_LongLoc"),
250 list = chainon (result, list);
252 result = build_enumerator (get_identifier ("__IO_ULongLoc"),
254 list = chainon (result, list);
256 result = build_enumerator (get_identifier ("__IO_ByteRangeLoc"),
258 list = chainon (result, list);
260 result = build_enumerator (get_identifier ("__IO_UByteRangeLoc"),
262 list = chainon (result, list);
264 result = build_enumerator (get_identifier ("__IO_IntRangeLoc"),
266 list = chainon (result, list);
268 result = build_enumerator (get_identifier ("__IO_UIntRangeLoc"),
270 list = chainon (result, list);
272 result = build_enumerator (get_identifier ("__IO_LongRangeLoc"),
274 list = chainon (result, list);
276 result = build_enumerator (get_identifier ("__IO_ULongRangeLoc"),
278 list = chainon (result, list);
280 result = build_enumerator (get_identifier ("__IO_BoolVal"),
282 list = chainon (result, list);
284 result = build_enumerator (get_identifier ("__IO_BoolLoc"),
286 list = chainon (result, list);
288 result = build_enumerator (get_identifier ("__IO_BoolRangeLoc"),
290 list = chainon (result, list);
292 result = build_enumerator (get_identifier ("__IO_SetVal"),
294 list = chainon (result, list);
296 result = build_enumerator (get_identifier ("__IO_SetLoc"),
298 list = chainon (result, list);
300 result = build_enumerator (get_identifier ("__IO_SetRangeLoc"),
302 list = chainon (result, list);
304 result = build_enumerator (get_identifier ("__IO_CharVal"),
306 list = chainon (result, list);
308 result = build_enumerator (get_identifier ("__IO_CharLoc"),
310 list = chainon (result, list);
312 result = build_enumerator (get_identifier ("__IO_CharRangeLoc"),
314 list = chainon (result, list);
316 result = build_enumerator (get_identifier ("__IO_CharStrLoc"),
318 list = chainon (result, list);
320 result = build_enumerator (get_identifier ("__IO_CharVaryingLoc"),
322 list = chainon (result, list);
324 result = build_enumerator (get_identifier ("__IO_BitStrLoc"),
326 list = chainon (result, list);
328 result = build_enumerator (get_identifier ("__IO_RealVal"),
330 list = chainon (result, list);
332 result = build_enumerator (get_identifier ("__IO_RealLoc"),
334 list = chainon (result, list);
336 result = build_enumerator (get_identifier ("__IO_LongRealVal"),
338 list = chainon (result, list);
340 result = build_enumerator (get_identifier ("__IO_LongRealLoc"),
342 list = chainon (result, list);
344 result = build_enumerator (get_identifier ("_IO_Pointer"),
346 list = chainon (result, list);
349 result = finish_enum (enum1, list);
350 pushdecl (io_descriptor = build_decl (TYPE_DECL,
351 get_identifier ("__tmp_IO_enum"),
353 /* prevent seizing/granting of the decl */
354 DECL_SOURCE_LINE (io_descriptor) = 0;
355 satisfy_decl (io_descriptor, 0);
357 /* build type for enum_tables */
358 decl1 = build_decl (FIELD_DECL, get_identifier ("value"),
360 DECL_INITIAL (decl1) = NULL_TREE;
361 decl2 = build_decl (FIELD_DECL, get_identifier ("name"),
362 build_pointer_type (char_type_node));
363 DECL_INITIAL (decl2) = NULL_TREE;
364 TREE_CHAIN (decl1) = decl2;
365 TREE_CHAIN (decl2) = NULL_TREE;
366 result = build_chill_struct_type (decl1);
367 pushdecl (enum_table_type = build_decl (TYPE_DECL,
368 get_identifier ("__tmp_IO_enum_table_type"),
370 DECL_SOURCE_LINE (enum_table_type) = 0;
371 satisfy_decl (enum_table_type, 0);
373 /* build type for writing a set mode */
374 decl1 = build_decl (FIELD_DECL, get_identifier ("value"),
376 DECL_INITIAL (decl1) = NULL_TREE;
379 decl2 = build_decl (FIELD_DECL, get_identifier ("name_table"),
380 build_pointer_type (TREE_TYPE (enum_table_type)));
381 DECL_INITIAL (decl2) = NULL_TREE;
382 TREE_CHAIN (decl1) = decl2;
384 TREE_CHAIN (decl2) = NULL_TREE;
386 result = build_chill_struct_type (listbase);
387 pushdecl (forset_W = build_decl (TYPE_DECL,
388 get_identifier ("__tmp_WIO_set"),
390 DECL_SOURCE_LINE (forset_W) = 0;
391 satisfy_decl (forset_W, 0);
393 /* build type for charrange */
394 decl1 = build_decl (FIELD_DECL, get_identifier ("ptr"),
395 build_pointer_type (char_type_node));
396 DECL_INITIAL (decl1) = NULL_TREE;
399 decl2 = build_decl (FIELD_DECL, get_identifier ("lower"),
401 DECL_INITIAL (decl2) = NULL_TREE;
402 TREE_CHAIN (decl1) = decl2;
405 decl2 = build_decl (FIELD_DECL, get_identifier ("upper"),
407 DECL_INITIAL (decl2) = NULL_TREE;
408 TREE_CHAIN (decl1) = decl2;
409 TREE_CHAIN (decl2) = NULL_TREE;
411 result = build_chill_struct_type (listbase);
412 pushdecl (forcharrange = build_decl (TYPE_DECL,
413 get_identifier ("__tmp_IO_charrange"),
415 DECL_SOURCE_LINE (forcharrange) = 0;
416 satisfy_decl (forcharrange, 0);
418 /* type for integer range */
419 decl1 = build_tree_list (NULL_TREE,
420 build_decl (FIELD_DECL,
421 get_identifier ("_slong"),
425 decl2 = build_tree_list (NULL_TREE,
426 build_decl (FIELD_DECL,
427 get_identifier ("_ulong"),
429 TREE_CHAIN (decl1) = decl2;
430 TREE_CHAIN (decl2) = NULL_TREE;
432 decl1 = grok_chill_variantdefs (NULL_TREE, listbase, NULL_TREE);
433 TREE_CHAIN (decl1) = NULL_TREE;
434 result = build_chill_struct_type (decl1);
435 pushdecl (intunion = build_decl (TYPE_DECL,
436 get_identifier ("__tmp_IO_long"),
438 DECL_SOURCE_LINE (intunion) = 0;
439 satisfy_decl (intunion, 0);
441 decl1 = build_decl (FIELD_DECL,
442 get_identifier ("ptr"),
446 decl2 = build_decl (FIELD_DECL,
447 get_identifier ("lower"),
448 TREE_TYPE (intunion));
449 TREE_CHAIN (decl1) = decl2;
452 decl2 = build_decl (FIELD_DECL,
453 get_identifier ("upper"),
454 TREE_TYPE (intunion));
455 TREE_CHAIN (decl1) = decl2;
456 TREE_CHAIN (decl2) = NULL_TREE;
458 result = build_chill_struct_type (listbase);
459 pushdecl (forintrange = build_decl (TYPE_DECL,
460 get_identifier ("__tmp_IO_intrange"),
462 DECL_SOURCE_LINE (forintrange) = 0;
463 satisfy_decl (forintrange, 0);
465 /* build structure for bool range */
466 decl1 = build_decl (FIELD_DECL,
467 get_identifier ("ptr"),
469 DECL_INITIAL (decl1) = NULL_TREE;
472 decl2 = build_decl (FIELD_DECL,
473 get_identifier ("lower"),
475 DECL_INITIAL (decl2) = NULL_TREE;
476 TREE_CHAIN (decl1) = decl2;
479 decl2 = build_decl (FIELD_DECL,
480 get_identifier ("upper"),
482 DECL_INITIAL (decl2) = NULL_TREE;
483 TREE_CHAIN (decl1) = decl2;
484 TREE_CHAIN (decl2) = NULL_TREE;
486 result = build_chill_struct_type (listbase);
487 pushdecl (forboolrange = build_decl (TYPE_DECL,
488 get_identifier ("__tmp_RIO_boolrange"),
490 DECL_SOURCE_LINE (forboolrange) = 0;
491 satisfy_decl (forboolrange, 0);
493 /* build type for reading a set */
494 decl1 = build_decl (FIELD_DECL, get_identifier ("ptr"),
496 DECL_INITIAL (decl1) = NULL_TREE;
499 decl2 = build_decl (FIELD_DECL, get_identifier ("length"),
501 DECL_INITIAL (decl2) = NULL_TREE;
502 TREE_CHAIN (decl1) = decl2;
505 decl2 = build_decl (FIELD_DECL, get_identifier ("name_table"),
506 build_pointer_type (TREE_TYPE (enum_table_type)));
507 DECL_INITIAL (decl2) = NULL_TREE;
508 TREE_CHAIN (decl1) = decl2;
509 TREE_CHAIN (decl2) = NULL_TREE;
511 result = build_chill_struct_type (listbase);
512 pushdecl (forset_R = build_decl (TYPE_DECL,
513 get_identifier ("__tmp_RIO_set"),
515 DECL_SOURCE_LINE (forset_R) = 0;
516 satisfy_decl (forset_R, 0);
518 /* build type for setrange */
519 decl1 = build_decl (FIELD_DECL, get_identifier ("ptr"),
521 DECL_INITIAL (decl1) = NULL_TREE;
524 decl2 = build_decl (FIELD_DECL, get_identifier ("length"),
526 DECL_INITIAL (decl2) = NULL_TREE;
527 TREE_CHAIN (decl1) = decl2;
530 decl2 = build_decl (FIELD_DECL, get_identifier ("name_table"),
531 build_pointer_type (TREE_TYPE (enum_table_type)));
532 DECL_INITIAL (decl2) = NULL_TREE;
533 TREE_CHAIN (decl1) = decl2;
536 decl2 = build_decl (FIELD_DECL, get_identifier ("lower"),
538 DECL_INITIAL (decl2) = NULL_TREE;
539 TREE_CHAIN (decl1) = decl2;
542 decl2 = build_decl (FIELD_DECL, get_identifier ("upper"),
544 DECL_INITIAL (decl2) = NULL_TREE;
545 TREE_CHAIN (decl1) = decl2;
546 TREE_CHAIN (decl2) = NULL_TREE;
548 result = build_chill_struct_type (listbase);
549 pushdecl (forsetrange = build_decl (TYPE_DECL,
550 get_identifier ("__tmp_RIO_setrange"),
552 DECL_SOURCE_LINE (forsetrange) = 0;
553 satisfy_decl (forsetrange, 0);
555 /* build structure for character string */
556 decl1 = build_decl (FIELD_DECL,
557 get_identifier ("string"),
558 build_pointer_type (char_type_node));
559 DECL_INITIAL (decl1) = NULL_TREE;
562 decl2 = build_decl (FIELD_DECL,
563 get_identifier ("string_length"),
565 DECL_INITIAL (decl2) = NULL_TREE;
566 TREE_CHAIN (decl1) = decl2;
568 TREE_CHAIN (decl2) = NULL_TREE;
570 result = build_chill_struct_type (listbase);
571 pushdecl (forcharstring = build_decl (TYPE_DECL,
572 get_identifier ("__tmp_IO_forcharstring"), result));
573 DECL_SOURCE_LINE (forcharstring) = 0;
574 satisfy_decl (forcharstring, 0);
576 /* build the union */
577 decl1 = build_tree_list (NULL_TREE,
578 build_decl (FIELD_DECL,
579 get_identifier ("__valbyte"),
580 signed_char_type_node));
583 decl2 = build_tree_list (NULL_TREE,
584 build_decl (FIELD_DECL,
585 get_identifier ("__valubyte"),
586 unsigned_char_type_node));
587 TREE_CHAIN (decl1) = decl2;
590 decl2 = build_tree_list (NULL_TREE,
591 build_decl (FIELD_DECL,
592 get_identifier ("__valint"),
593 chill_integer_type_node));
594 TREE_CHAIN (decl1) = decl2;
597 decl2 = build_tree_list (NULL_TREE,
598 build_decl (FIELD_DECL,
599 get_identifier ("__valuint"),
600 chill_unsigned_type_node));
601 TREE_CHAIN (decl1) = decl2;
604 decl2 = build_tree_list (NULL_TREE,
605 build_decl (FIELD_DECL,
606 get_identifier ("__vallong"),
608 TREE_CHAIN (decl1) = decl2;
611 decl2 = build_tree_list (NULL_TREE,
612 build_decl (FIELD_DECL,
613 get_identifier ("__valulong"),
615 TREE_CHAIN (decl1) = decl2;
618 decl2 = build_tree_list (NULL_TREE,
619 build_decl (FIELD_DECL,
620 get_identifier ("__locint"),
622 TREE_CHAIN (decl1) = decl2;
625 decl2 = build_tree_list (NULL_TREE,
626 build_decl (FIELD_DECL,
627 get_identifier ("__locintrange"),
628 TREE_TYPE (forintrange)));
629 TREE_CHAIN (decl1) = decl2;
632 decl2 = build_tree_list (NULL_TREE,
633 build_decl (FIELD_DECL,
634 get_identifier ("__valbool"),
636 TREE_CHAIN (decl1) = decl2;
639 decl2 = build_tree_list (NULL_TREE,
640 build_decl (FIELD_DECL,
641 get_identifier ("__locbool"),
642 build_pointer_type (boolean_type_node)));
643 TREE_CHAIN (decl1) = decl2;
646 decl2 = build_tree_list (NULL_TREE,
647 build_decl (FIELD_DECL,
648 get_identifier ("__locboolrange"),
649 TREE_TYPE (forboolrange)));
650 TREE_CHAIN (decl1) = decl2;
653 decl2 = build_tree_list (NULL_TREE,
654 build_decl (FIELD_DECL,
655 get_identifier ("__valset"),
656 TREE_TYPE (forset_W)));
657 TREE_CHAIN (decl1) = decl2;
660 decl2 = build_tree_list (NULL_TREE,
661 build_decl (FIELD_DECL,
662 get_identifier ("__locset"),
663 TREE_TYPE (forset_R)));
664 TREE_CHAIN (decl1) = decl2;
667 decl2 = build_tree_list (NULL_TREE,
668 build_decl (FIELD_DECL,
669 get_identifier ("__locsetrange"),
670 TREE_TYPE (forsetrange)));
671 TREE_CHAIN (decl1) = decl2;
674 decl2 = build_tree_list (NULL_TREE,
675 build_decl (FIELD_DECL,
676 get_identifier ("__valchar"),
678 TREE_CHAIN (decl1) = decl2;
681 decl2 = build_tree_list (NULL_TREE,
682 build_decl (FIELD_DECL,
683 get_identifier ("__locchar"),
684 build_pointer_type (char_type_node)));
685 TREE_CHAIN (decl1) = decl2;
688 decl2 = build_tree_list (NULL_TREE,
689 build_decl (FIELD_DECL,
690 get_identifier ("__loccharrange"),
691 TREE_TYPE (forcharrange)));
692 TREE_CHAIN (decl1) = decl2;
695 decl2 = build_tree_list (NULL_TREE,
696 build_decl (FIELD_DECL,
697 get_identifier ("__loccharstring"),
698 TREE_TYPE (forcharstring)));
699 TREE_CHAIN (decl1) = decl2;
702 decl2 = build_tree_list (NULL_TREE,
703 build_decl (FIELD_DECL,
704 get_identifier ("__valreal"),
706 TREE_CHAIN (decl1) = decl2;
709 decl2 = build_tree_list (NULL_TREE,
710 build_decl (FIELD_DECL,
711 get_identifier ("__locreal"),
712 build_pointer_type (float_type_node)));
713 TREE_CHAIN (decl1) = decl2;
716 decl2 = build_tree_list (NULL_TREE,
717 build_decl (FIELD_DECL,
718 get_identifier ("__vallongreal"),
720 TREE_CHAIN (decl1) = decl2;
723 decl2 = build_tree_list (NULL_TREE,
724 build_decl (FIELD_DECL,
725 get_identifier ("__loclongreal"),
726 build_pointer_type (double_type_node)));
727 TREE_CHAIN (decl1) = decl2;
731 decl2 = build_tree_list (NULL_TREE,
732 build_decl (FIELD_DECL,
733 get_identifier ("__forpointer"),
735 TREE_CHAIN (decl1) = decl2;
739 TREE_CHAIN (decl2) = NULL_TREE;
741 decl1 = grok_chill_variantdefs (NULL_TREE, listbase, NULL_TREE);
742 TREE_CHAIN (decl1) = NULL_TREE;
743 result = build_chill_struct_type (decl1);
744 pushdecl (union_type = build_decl (TYPE_DECL,
745 get_identifier ("__tmp_WIO_union"),
747 DECL_SOURCE_LINE (union_type) = 0;
748 satisfy_decl (union_type, 0);
750 /* now build the final structure */
751 decl1 = build_decl (FIELD_DECL, get_identifier ("__t"),
752 TREE_TYPE (union_type));
753 DECL_INITIAL (decl1) = NULL_TREE;
756 decl2 = build_decl (FIELD_DECL, get_identifier ("__descr"),
759 TREE_CHAIN (decl1) = decl2;
760 TREE_CHAIN (decl2) = NULL_TREE;
762 result = build_chill_struct_type (listbase);
763 pushdecl (chill_io_list_type = build_decl (TYPE_DECL,
764 get_identifier ("__tmp_IO_list"),
766 DECL_SOURCE_LINE (chill_io_list_type) = 0;
767 satisfy_decl (chill_io_list_type, 0);
770 /* build the ASSOCIATION, ACCESS and TEXT mode types */
774 tree listbase, decl1, decl2, result, association;
778 /* the association mode */
779 listbase = build_decl (FIELD_DECL,
780 get_identifier ("flags"),
781 long_unsigned_type_node);
782 DECL_INITIAL (listbase) = NULL_TREE;
785 decl2 = build_decl (FIELD_DECL,
786 get_identifier ("pathname"),
788 DECL_INITIAL (decl2) = NULL_TREE;
789 TREE_CHAIN (decl1) = decl2;
792 decl2 = build_decl (FIELD_DECL,
793 get_identifier ("access"),
795 DECL_INITIAL (decl2) = NULL_TREE;
796 TREE_CHAIN (decl1) = decl2;
799 decl2 = build_decl (FIELD_DECL,
800 get_identifier ("handle"),
802 DECL_INITIAL (decl2) = NULL_TREE;
803 TREE_CHAIN (decl1) = decl2;
806 decl2 = build_decl (FIELD_DECL,
807 get_identifier ("bufptr"),
809 DECL_INITIAL (decl2) = NULL_TREE;
810 TREE_CHAIN (decl1) = decl2;
813 decl2 = build_decl (FIELD_DECL,
814 get_identifier ("syserrno"),
815 long_integer_type_node);
816 DECL_INITIAL (decl2) = NULL_TREE;
817 TREE_CHAIN (decl1) = decl2;
820 decl2 = build_decl (FIELD_DECL,
821 get_identifier ("usage"),
823 DECL_INITIAL (decl2) = NULL_TREE;
824 TREE_CHAIN (decl1) = decl2;
827 decl2 = build_decl (FIELD_DECL,
828 get_identifier ("ctl_pre"),
830 DECL_INITIAL (decl2) = NULL_TREE;
831 TREE_CHAIN (decl1) = decl2;
834 decl2 = build_decl (FIELD_DECL,
835 get_identifier ("ctl_post"),
837 DECL_INITIAL (decl2) = NULL_TREE;
838 TREE_CHAIN (decl1) = decl2;
839 TREE_CHAIN (decl2) = NULL_TREE;
841 result = build_chill_struct_type (listbase);
842 pushdecl (association = build_decl (TYPE_DECL,
843 ridpointers[(int)RID_ASSOCIATION],
845 DECL_SOURCE_LINE (association) = 0;
846 satisfy_decl (association, 0);
847 association_type_node = TREE_TYPE (association);
848 TYPE_NAME (association_type_node) = association;
849 CH_NOVELTY (association_type_node) = association;
850 CH_TYPE_NONVALUE_P(association_type_node) = 1;
851 CH_TYPE_NONVALUE_P(association) = 1;
853 /* initialiser for association type */
854 tmp = convert (char_type_node, integer_zero_node);
855 association_init_value =
856 build_nt (CONSTRUCTOR, NULL_TREE,
857 tree_cons (NULL_TREE, integer_zero_node, /* flags */
858 tree_cons (NULL_TREE, null_pointer_node, /* pathname */
859 tree_cons (NULL_TREE, null_pointer_node, /* access */
860 tree_cons (NULL_TREE, integer_minus_one_node, /* handle */
861 tree_cons (NULL_TREE, null_pointer_node, /* bufptr */
862 tree_cons (NULL_TREE, integer_zero_node, /* syserrno */
863 tree_cons (NULL_TREE, tmp, /* usage */
864 tree_cons (NULL_TREE, tmp, /* ctl_pre */
865 tree_cons (NULL_TREE, tmp, /* ctl_post */
868 /* the type for stdin, stdout, stderr */
870 decl1 = build_decl (FIELD_DECL,
871 get_identifier ("flags"),
872 long_unsigned_type_node);
873 DECL_INITIAL (decl1) = NULL_TREE;
876 decl2 = build_decl (FIELD_DECL,
877 get_identifier ("text_record"),
879 DECL_INITIAL (decl2) = NULL_TREE;
880 TREE_CHAIN (decl1) = decl2;
883 decl2 = build_decl (FIELD_DECL,
884 get_identifier ("access_sub"),
886 DECL_INITIAL (decl2) = NULL_TREE;
887 TREE_CHAIN (decl1) = decl2;
890 decl2 = build_decl (FIELD_DECL,
891 get_identifier ("actual_index"),
892 long_unsigned_type_node);
893 DECL_INITIAL (decl2) = NULL_TREE;
894 TREE_CHAIN (decl1) = decl2;
895 TREE_CHAIN (decl2) = NULL_TREE;
896 txt = build_chill_struct_type (listbase);
899 decl1 = build_decl (FIELD_DECL,
900 get_identifier ("flags"),
901 long_unsigned_type_node);
902 DECL_INITIAL (decl1) = NULL_TREE;
905 decl2 = build_decl (FIELD_DECL,
906 get_identifier ("reclength"),
907 long_unsigned_type_node);
908 DECL_INITIAL (decl2) = NULL_TREE;
909 TREE_CHAIN (decl1) = decl2;
912 decl2 = build_decl (FIELD_DECL,
913 get_identifier ("lowindex"),
914 long_integer_type_node);
915 DECL_INITIAL (decl2) = NULL_TREE;
916 TREE_CHAIN (decl1) = decl2;
919 decl2 = build_decl (FIELD_DECL,
920 get_identifier ("highindex"),
921 long_integer_type_node);
922 DECL_INITIAL (decl2) = NULL_TREE;
923 TREE_CHAIN (decl1) = decl2;
926 decl2 = build_decl (FIELD_DECL,
927 get_identifier ("association"),
929 DECL_INITIAL (decl2) = NULL_TREE;
930 TREE_CHAIN (decl1) = decl2;
933 decl2 = build_decl (FIELD_DECL,
934 get_identifier ("base"),
935 long_unsigned_type_node);
936 DECL_INITIAL (decl2) = NULL_TREE;
937 TREE_CHAIN (decl1) = decl2;
940 decl2 = build_decl (FIELD_DECL,
941 get_identifier ("storelocptr"),
943 DECL_INITIAL (decl2) = NULL_TREE;
944 TREE_CHAIN (decl1) = decl2;
947 decl2 = build_decl (FIELD_DECL,
948 get_identifier ("rectype"),
949 long_integer_type_node);
950 DECL_INITIAL (decl2) = NULL_TREE;
951 TREE_CHAIN (decl1) = decl2;
952 TREE_CHAIN (decl2) = NULL_TREE;
953 acc = build_chill_struct_type (listbase);
956 tmp = build_string_type (char_type_node, build_int_2 (STDIO_TEXT_LENGTH, 0));
957 tloc = build_varying_struct (tmp);
959 /* now the final mode */
960 decl1 = build_decl (FIELD_DECL, get_identifier ("txt"), txt);
963 decl2 = build_decl (FIELD_DECL, get_identifier ("acc"), acc);
964 TREE_CHAIN (decl1) = decl2;
967 decl2 = build_decl (FIELD_DECL, get_identifier ("tloc"), tloc);
968 TREE_CHAIN (decl1) = decl2;
971 decl2 = build_lang_decl (TYPE_DECL, get_identifier ("__indexmode"),
973 TREE_CHAIN (decl1) = decl2;
976 decl2 = build_decl (CONST_DECL, get_identifier ("__textlength"),
978 DECL_INITIAL (decl2) = build_int_2 (STDIO_TEXT_LENGTH, 0);
979 TREE_CHAIN (decl1) = decl2;
982 decl2 = build_decl (CONST_DECL, get_identifier ("__dynamic"),
984 DECL_INITIAL (decl2) = integer_zero_node;
985 TREE_CHAIN (decl1) = decl2;
986 TREE_CHAIN (decl2) = NULL_TREE;
988 result = build_chill_struct_type (listbase);
989 pushdecl (tmp = build_decl (TYPE_DECL,
990 get_identifier ("__stdio_text"),
992 DECL_SOURCE_LINE (tmp) = 0;
993 satisfy_decl (tmp, 0);
994 stdio_type_node = TREE_TYPE (tmp);
995 CH_IS_TEXT_MODE (stdio_type_node) = 1;
997 /* predefined usage mode */
998 enum1 = start_enum (NULL_TREE);
999 listbase = NULL_TREE;
1000 result = build_enumerator (
1001 get_identifier ((ignore_case || ! special_UC) ? "readonly" : "READONLY"),
1003 listbase = chainon (result, listbase);
1004 result = build_enumerator (
1005 get_identifier ((ignore_case || ! special_UC) ? "writeonly" : "WRITEONLY"),
1007 listbase = chainon (result, listbase);
1008 result = build_enumerator (
1009 get_identifier ((ignore_case || ! special_UC) ? "readwrite" : "READWRITE"),
1011 listbase = chainon (result, listbase);
1012 result = finish_enum (enum1, listbase);
1013 pushdecl (tmp = build_decl (TYPE_DECL,
1014 get_identifier ((ignore_case || ! special_UC) ? "usage" : "USAGE"),
1016 DECL_SOURCE_LINE (tmp) = 0;
1017 satisfy_decl (tmp, 0);
1018 usage_type_node = TREE_TYPE (tmp);
1019 TYPE_NAME (usage_type_node) = tmp;
1020 CH_NOVELTY (usage_type_node) = tmp;
1022 /* predefined where mode */
1023 enum1 = start_enum (NULL_TREE);
1024 listbase = NULL_TREE;
1025 result = build_enumerator (
1026 get_identifier ((ignore_case || ! special_UC) ? "first" : "FIRST"),
1028 listbase = chainon (result, listbase);
1029 result = build_enumerator (
1030 get_identifier ((ignore_case || ! special_UC) ? "same" : "SAME"),
1032 listbase = chainon (result, listbase);
1033 result = build_enumerator (
1034 get_identifier ((ignore_case || ! special_UC) ? "last" : "LAST"),
1036 listbase = chainon (result, listbase);
1037 result = finish_enum (enum1, listbase);
1038 pushdecl (tmp = build_decl (TYPE_DECL,
1039 get_identifier ((ignore_case || ! special_UC) ? "where" : "WHERE"),
1041 DECL_SOURCE_LINE (tmp) = 0;
1042 satisfy_decl (tmp, 0);
1043 where_type_node = TREE_TYPE (tmp);
1044 TYPE_NAME (where_type_node) = tmp;
1045 CH_NOVELTY (where_type_node) = tmp;
1049 declare_predefined_file (name, assembler_name)
1051 char* assembler_name;
1053 tree decl = build_lang_decl (VAR_DECL, get_identifier (name),
1055 DECL_ASSEMBLER_NAME (decl) = get_identifier(assembler_name);
1056 TREE_STATIC (decl) = 1;
1057 TREE_PUBLIC (decl) = 1;
1058 DECL_EXTERNAL (decl) = 1;
1059 DECL_IN_SYSTEM_HEADER (decl) = 1;
1060 make_decl_rtl (decl, 0, 1);
1065 /* initialisation of all IO/related functions, types, etc. */
1069 /* We temporarily reset the maximum_field_alignment to zero so the
1070 compiler's init data structures can be compatible with the
1071 run-time system, even when we're compiling with -fpack. */
1072 extern int maximum_field_alignment;
1073 int save_maximum_field_alignment = maximum_field_alignment;
1075 extern tree chill_predefined_function_type;
1076 tree endlink = void_list_node;
1077 tree bool_ftype_ptr_ptr_int;
1078 tree ptr_ftype_ptr_ptr_int;
1079 tree luns_ftype_ptr_ptr_int;
1080 tree int_ftype_ptr_ptr_int;
1081 tree ptr_ftype_ptr_ptr_int_ptr_int_ptr_int;
1082 tree void_ftype_ptr_ptr_int_ptr_int_ptr_int;
1083 tree void_ftype_ptr_ptr_int;
1084 tree void_ftype_ptr_ptr_int_int_int_long_ptr_int;
1085 tree ptr_ftype_ptr_int_ptr_ptr_int;
1086 tree void_ftype_ptr_int_ptr_luns_ptr_int;
1087 tree void_ftype_ptr_ptr_ptr_int;
1088 tree void_ftype_ptr_int_ptr_int;
1089 tree void_ftype_ptr_int_ptr_int_ptr_int_ptr_int;
1091 maximum_field_alignment = 0;
1093 builtin_function ((ignore_case || ! special_UC) ? "associate" : "ASSOCIATE",
1094 chill_predefined_function_type,
1095 BUILT_IN_ASSOCIATE, NULL_PTR);
1096 builtin_function ((ignore_case || ! special_UC) ? "connect" : "CONNECT",
1097 chill_predefined_function_type,
1098 BUILT_IN_CONNECT, NULL_PTR);
1099 builtin_function ((ignore_case || ! special_UC) ? "create" : "CREATE",
1100 chill_predefined_function_type,
1101 BUILT_IN_CREATE, NULL_PTR);
1102 builtin_function ((ignore_case || ! special_UC) ? "delete" : "DELETE",
1103 chill_predefined_function_type,
1104 BUILT_IN_CH_DELETE, NULL_PTR);
1105 builtin_function ((ignore_case || ! special_UC) ? "disconnect" : "DISCONNECT",
1106 chill_predefined_function_type,
1107 BUILT_IN_DISCONNECT, NULL_PTR);
1108 builtin_function ((ignore_case || ! special_UC) ? "dissociate" : "DISSOCIATE",
1109 chill_predefined_function_type,
1110 BUILT_IN_DISSOCIATE, NULL_PTR);
1111 builtin_function ((ignore_case || ! special_UC) ? "eoln" : "EOLN",
1112 chill_predefined_function_type,
1113 BUILT_IN_EOLN, NULL_PTR);
1114 builtin_function ((ignore_case || ! special_UC) ? "existing" : "EXISTING",
1115 chill_predefined_function_type,
1116 BUILT_IN_EXISTING, NULL_PTR);
1117 builtin_function ((ignore_case || ! special_UC) ? "getassociation" : "GETASSOCIATION",
1118 chill_predefined_function_type,
1119 BUILT_IN_GETASSOCIATION, NULL_PTR);
1120 builtin_function ((ignore_case || ! special_UC) ? "gettextaccess" : "GETTEXTASSCESS",
1121 chill_predefined_function_type,
1122 BUILT_IN_GETTEXTACCESS, NULL_PTR);
1123 builtin_function ((ignore_case || ! special_UC) ? "gettextindex" : "GETTEXTINDEX",
1124 chill_predefined_function_type,
1125 BUILT_IN_GETTEXTINDEX, NULL_PTR);
1126 builtin_function ((ignore_case || ! special_UC) ? "gettextrecord" : "GETTEXTRECORD",
1127 chill_predefined_function_type,
1128 BUILT_IN_GETTEXTRECORD, NULL_PTR);
1129 builtin_function ((ignore_case || ! special_UC) ? "getusage" : "GETUSAGE",
1130 chill_predefined_function_type,
1131 BUILT_IN_GETUSAGE, NULL_PTR);
1132 builtin_function ((ignore_case || ! special_UC) ? "indexable" : "INDEXABLE",
1133 chill_predefined_function_type,
1134 BUILT_IN_INDEXABLE, NULL_PTR);
1135 builtin_function ((ignore_case || ! special_UC) ? "isassociated" : "ISASSOCIATED",
1136 chill_predefined_function_type,
1137 BUILT_IN_ISASSOCIATED, NULL_PTR);
1138 builtin_function ((ignore_case || ! special_UC) ? "modify" : "MODIFY",
1139 chill_predefined_function_type,
1140 BUILT_IN_MODIFY, NULL_PTR);
1141 builtin_function ((ignore_case || ! special_UC) ? "outoffile" : "OUTOFFILE",
1142 chill_predefined_function_type,
1143 BUILT_IN_OUTOFFILE, NULL_PTR);
1144 builtin_function ((ignore_case || ! special_UC) ? "readable" : "READABLE",
1145 chill_predefined_function_type,
1146 BUILT_IN_READABLE, NULL_PTR);
1147 builtin_function ((ignore_case || ! special_UC) ? "readrecord" : "READRECORD",
1148 chill_predefined_function_type,
1149 BUILT_IN_READRECORD, NULL_PTR);
1150 builtin_function ((ignore_case || ! special_UC) ? "readtext" : "READTEXT",
1151 chill_predefined_function_type,
1152 BUILT_IN_READTEXT, NULL_PTR);
1153 builtin_function ((ignore_case || ! special_UC) ? "sequencible" : "SEQUENCIBLE",
1154 chill_predefined_function_type,
1155 BUILT_IN_SEQUENCIBLE, NULL_PTR);
1156 builtin_function ((ignore_case || ! special_UC) ? "settextaccess" : "SETTEXTACCESS",
1157 chill_predefined_function_type,
1158 BUILT_IN_SETTEXTACCESS, NULL_PTR);
1159 builtin_function ((ignore_case || ! special_UC) ? "settextindex" : "SETTEXTINDEX",
1160 chill_predefined_function_type,
1161 BUILT_IN_SETTEXTINDEX, NULL_PTR);
1162 builtin_function ((ignore_case || ! special_UC) ? "settextrecord" : "SETTEXTRECORD",
1163 chill_predefined_function_type,
1164 BUILT_IN_SETTEXTRECORD, NULL_PTR);
1165 builtin_function ((ignore_case || ! special_UC) ? "variable" : "VARIABLE",
1166 chill_predefined_function_type,
1167 BUILT_IN_VARIABLE, NULL_PTR);
1168 builtin_function ((ignore_case || ! special_UC) ? "writeable" : "WRITEABLE",
1169 chill_predefined_function_type,
1170 BUILT_IN_WRITEABLE, NULL_PTR);
1171 builtin_function ((ignore_case || ! special_UC) ? "writerecord" : "WRITERECORD",
1172 chill_predefined_function_type,
1173 BUILT_IN_WRITERECORD, NULL_PTR);
1174 builtin_function ((ignore_case || ! special_UC) ? "writetext" : "WRITETEXT",
1175 chill_predefined_function_type,
1176 BUILT_IN_WRITETEXT, NULL_PTR);
1178 /* build function prototypes */
1179 bool_ftype_ptr_ptr_int =
1180 build_function_type (boolean_type_node,
1181 tree_cons (NULL_TREE, ptr_type_node,
1182 tree_cons (NULL_TREE, ptr_type_node,
1183 tree_cons (NULL_TREE, integer_type_node,
1185 ptr_ftype_ptr_ptr_int_ptr_int_ptr_int =
1186 build_function_type (ptr_type_node,
1187 tree_cons (NULL_TREE, ptr_type_node,
1188 tree_cons (NULL_TREE, ptr_type_node,
1189 tree_cons (NULL_TREE, integer_type_node,
1190 tree_cons (NULL_TREE, ptr_type_node,
1191 tree_cons (NULL_TREE, integer_type_node,
1192 tree_cons (NULL_TREE, ptr_type_node,
1193 tree_cons (NULL_TREE, integer_type_node,
1195 void_ftype_ptr_ptr_int =
1196 build_function_type (void_type_node,
1197 tree_cons (NULL_TREE, ptr_type_node,
1198 tree_cons (NULL_TREE, ptr_type_node,
1199 tree_cons (NULL_TREE, integer_type_node,
1201 void_ftype_ptr_ptr_int_ptr_int_ptr_int =
1202 build_function_type (void_type_node,
1203 tree_cons (NULL_TREE, ptr_type_node,
1204 tree_cons (NULL_TREE, ptr_type_node,
1205 tree_cons (NULL_TREE, integer_type_node,
1206 tree_cons (NULL_TREE, ptr_type_node,
1207 tree_cons (NULL_TREE, integer_type_node,
1208 tree_cons (NULL_TREE, ptr_type_node,
1209 tree_cons (NULL_TREE, integer_type_node,
1211 void_ftype_ptr_ptr_int_int_int_long_ptr_int =
1212 build_function_type (void_type_node,
1213 tree_cons (NULL_TREE, ptr_type_node,
1214 tree_cons (NULL_TREE, ptr_type_node,
1215 tree_cons (NULL_TREE, integer_type_node,
1216 tree_cons (NULL_TREE, integer_type_node,
1217 tree_cons (NULL_TREE, integer_type_node,
1218 tree_cons (NULL_TREE, long_integer_type_node,
1219 tree_cons (NULL_TREE, ptr_type_node,
1220 tree_cons (NULL_TREE, integer_type_node,
1222 ptr_ftype_ptr_ptr_int =
1223 build_function_type (ptr_type_node,
1224 tree_cons (NULL_TREE, ptr_type_node,
1225 tree_cons (NULL_TREE, ptr_type_node,
1226 tree_cons (NULL_TREE, integer_type_node,
1228 int_ftype_ptr_ptr_int =
1229 build_function_type (integer_type_node,
1230 tree_cons (NULL_TREE, ptr_type_node,
1231 tree_cons (NULL_TREE, ptr_type_node,
1232 tree_cons (NULL_TREE, integer_type_node,
1234 ptr_ftype_ptr_int_ptr_ptr_int =
1235 build_function_type (ptr_type_node,
1236 tree_cons (NULL_TREE, ptr_type_node,
1237 tree_cons (NULL_TREE, integer_type_node,
1238 tree_cons (NULL_TREE, ptr_type_node,
1239 tree_cons (NULL_TREE, ptr_type_node,
1240 tree_cons (NULL_TREE, integer_type_node,
1242 void_ftype_ptr_int_ptr_luns_ptr_int =
1243 build_function_type (void_type_node,
1244 tree_cons (NULL_TREE, ptr_type_node,
1245 tree_cons (NULL_TREE, integer_type_node,
1246 tree_cons (NULL_TREE, ptr_type_node,
1247 tree_cons (NULL_TREE, long_unsigned_type_node,
1248 tree_cons (NULL_TREE, ptr_type_node,
1249 tree_cons (NULL_TREE, integer_type_node,
1251 luns_ftype_ptr_ptr_int =
1252 build_function_type (long_unsigned_type_node,
1253 tree_cons (NULL_TREE, ptr_type_node,
1254 tree_cons (NULL_TREE, ptr_type_node,
1255 tree_cons (NULL_TREE, integer_type_node,
1257 void_ftype_ptr_ptr_ptr_int =
1258 build_function_type (void_type_node,
1259 tree_cons (NULL_TREE, ptr_type_node,
1260 tree_cons (NULL_TREE, ptr_type_node,
1261 tree_cons (NULL_TREE, ptr_type_node,
1262 tree_cons (NULL_TREE, integer_type_node,
1264 void_ftype_ptr_int_ptr_int =
1265 build_function_type (void_type_node,
1266 tree_cons (NULL_TREE, ptr_type_node,
1267 tree_cons (NULL_TREE, integer_type_node,
1268 tree_cons (NULL_TREE, ptr_type_node,
1269 tree_cons (NULL_TREE, integer_type_node,
1271 void_ftype_ptr_int_ptr_int_ptr_int_ptr_int =
1272 build_function_type (void_type_node,
1273 tree_cons (NULL_TREE, ptr_type_node,
1274 tree_cons (NULL_TREE, integer_type_node,
1275 tree_cons (NULL_TREE, ptr_type_node,
1276 tree_cons (NULL_TREE, integer_type_node,
1277 tree_cons (NULL_TREE, ptr_type_node,
1278 tree_cons (NULL_TREE, integer_type_node,
1279 tree_cons (NULL_TREE, ptr_type_node,
1280 tree_cons (NULL_TREE, integer_type_node,
1283 builtin_function ("__associate", ptr_ftype_ptr_ptr_int_ptr_int_ptr_int,
1284 NOT_BUILT_IN, NULL_PTR);
1285 builtin_function ("__connect", void_ftype_ptr_ptr_int_int_int_long_ptr_int,
1286 NOT_BUILT_IN, NULL_PTR);
1287 builtin_function ("__create", void_ftype_ptr_ptr_int,
1288 NOT_BUILT_IN, NULL_PTR);
1289 builtin_function ("__delete", void_ftype_ptr_ptr_int,
1290 NOT_BUILT_IN, NULL_PTR);
1291 builtin_function ("__disconnect", void_ftype_ptr_ptr_int,
1292 NOT_BUILT_IN, NULL_PTR);
1293 builtin_function ("__dissociate", void_ftype_ptr_ptr_int,
1294 NOT_BUILT_IN, NULL_PTR);
1295 builtin_function ("__eoln", bool_ftype_ptr_ptr_int,
1296 NOT_BUILT_IN, NULL_PTR);
1297 builtin_function ("__existing", bool_ftype_ptr_ptr_int,
1298 NOT_BUILT_IN, NULL_PTR);
1299 builtin_function ("__getassociation", ptr_ftype_ptr_ptr_int,
1300 NOT_BUILT_IN, NULL_PTR);
1301 builtin_function ("__gettextaccess", ptr_ftype_ptr_ptr_int,
1302 NOT_BUILT_IN, NULL_PTR);
1303 builtin_function ("__gettextindex", luns_ftype_ptr_ptr_int,
1304 NOT_BUILT_IN, NULL_PTR);
1305 builtin_function ("__gettextrecord", ptr_ftype_ptr_ptr_int,
1306 NOT_BUILT_IN, NULL_PTR);
1307 builtin_function ("__getusage", int_ftype_ptr_ptr_int,
1308 NOT_BUILT_IN, NULL_PTR);
1309 builtin_function ("__indexable", bool_ftype_ptr_ptr_int,
1310 NOT_BUILT_IN, NULL_PTR);
1311 builtin_function ("__isassociated", bool_ftype_ptr_ptr_int,
1312 NOT_BUILT_IN, NULL_PTR);
1313 builtin_function ("__modify", void_ftype_ptr_ptr_int_ptr_int_ptr_int,
1314 NOT_BUILT_IN, NULL_PTR);
1315 builtin_function ("__outoffile", bool_ftype_ptr_ptr_int,
1316 NOT_BUILT_IN, NULL_PTR);
1317 builtin_function ("__readable", bool_ftype_ptr_ptr_int,
1318 NOT_BUILT_IN, NULL_PTR);
1319 builtin_function ("__readrecord", ptr_ftype_ptr_int_ptr_ptr_int,
1320 NOT_BUILT_IN, NULL_PTR);
1321 builtin_function ("__readtext_f", void_ftype_ptr_int_ptr_int_ptr_int_ptr_int,
1322 NOT_BUILT_IN, NULL_PTR);
1323 builtin_function ("__readtext_s", void_ftype_ptr_int_ptr_int_ptr_int_ptr_int,
1324 NOT_BUILT_IN, NULL_PTR);
1325 builtin_function ("__sequencible", bool_ftype_ptr_ptr_int,
1326 NOT_BUILT_IN, NULL_PTR);
1327 builtin_function ("__settextaccess", void_ftype_ptr_ptr_ptr_int,
1328 NOT_BUILT_IN, NULL_PTR);
1329 builtin_function ("__settextindex", void_ftype_ptr_int_ptr_int,
1330 NOT_BUILT_IN, NULL_PTR);
1331 builtin_function ("__settextrecord", void_ftype_ptr_ptr_ptr_int,
1332 NOT_BUILT_IN, NULL_PTR);
1333 builtin_function ("__variable", bool_ftype_ptr_ptr_int,
1334 NOT_BUILT_IN, NULL_PTR);
1335 builtin_function ("__writeable", bool_ftype_ptr_ptr_int,
1336 NOT_BUILT_IN, NULL_PTR);
1337 builtin_function ("__writerecord", void_ftype_ptr_int_ptr_luns_ptr_int,
1338 NOT_BUILT_IN, NULL_PTR);
1339 builtin_function ("__writetext_f", void_ftype_ptr_int_ptr_int_ptr_int_ptr_int,
1340 NOT_BUILT_IN, NULL_PTR);
1341 builtin_function ("__writetext_s", void_ftype_ptr_int_ptr_int_ptr_int_ptr_int,
1342 NOT_BUILT_IN, NULL_PTR);
1344 /* declare ASSOCIATION, ACCESS, and TEXT modes */
1347 /* declare the predefined text locations */
1348 declare_predefined_file ((ignore_case || ! special_UC) ? "stdin" : "STDIN",
1350 declare_predefined_file ((ignore_case || ! special_UC) ? "stdout" : "STDOUT",
1352 declare_predefined_file ((ignore_case || ! special_UC) ? "stderr" : "STDERR",
1355 /* last, but not least, build the chill IO-list type */
1356 build_chill_io_list_type ();
1358 maximum_field_alignment = save_maximum_field_alignment;
1361 /* function returns the recordmode of an ACCESS */
1363 access_recordmode (access)
1368 if (access == NULL_TREE || TREE_CODE (access) == ERROR_MARK)
1370 if (! CH_IS_ACCESS_MODE (access))
1373 field = TYPE_FIELDS (access);
1374 for ( ; field != NULL_TREE; field = TREE_CHAIN (field))
1376 if (TREE_CODE (field) == TYPE_DECL &&
1377 DECL_NAME (field) == get_identifier ("__recordmode"))
1378 return TREE_TYPE (field);
1380 return void_type_node;
1383 /* function invalidates the recordmode of an ACCESS */
1385 invalidate_access_recordmode (access)
1390 if (access == NULL_TREE || TREE_CODE (access) == ERROR_MARK)
1392 if (! CH_IS_ACCESS_MODE (access))
1395 field = TYPE_FIELDS (access);
1396 for ( ; field != NULL_TREE; field = TREE_CHAIN (field))
1398 if (TREE_CODE (field) == TYPE_DECL &&
1399 DECL_NAME (field) == get_identifier ("__recordmode"))
1401 TREE_TYPE (field) = error_mark_node;
1407 /* function returns the index mode of an ACCESS if there is one,
1408 otherwise NULL_TREE */
1410 access_indexmode (access)
1415 if (access == NULL_TREE || TREE_CODE (access) == ERROR_MARK)
1417 if (! CH_IS_ACCESS_MODE (access))
1420 field = TYPE_FIELDS (access);
1421 for ( ; field != NULL_TREE; field = TREE_CHAIN (field))
1423 if (TREE_CODE (field) == TYPE_DECL &&
1424 DECL_NAME (field) == get_identifier ("__indexmode"))
1425 return TREE_TYPE (field);
1427 return void_type_node;
1430 /* function returns one if an ACCESS was specified DYNAMIC, otherwise zero */
1432 access_dynamic (access)
1437 if (access == NULL_TREE || TREE_CODE (access) == ERROR_MARK)
1439 if (! CH_IS_ACCESS_MODE (access))
1442 field = TYPE_FIELDS (access);
1443 for ( ; field != NULL_TREE; field = TREE_CHAIN (field))
1445 if (TREE_CODE (field) == CONST_DECL)
1446 return DECL_INITIAL (field);
1448 return integer_zero_node;
1452 returns a structure like
1453 STRUCT (data STRUCT (flags ULONG,
1461 this is followed by a
1462 TYPE_DECL __recordmode recordmode ? recordmode : void_type_node
1463 TYPE_DECL __indexmode indexmode ? indexmode : void_type_node
1464 CONST_DECL __dynamic dynamic ? integer_one_node : integer_zero_node
1468 build_access_part ()
1470 tree listbase, decl;
1472 listbase = build_decl (FIELD_DECL, get_identifier ("flags"),
1473 long_unsigned_type_node);
1474 decl = build_decl (FIELD_DECL, get_identifier ("reclength"),
1475 long_unsigned_type_node);
1476 listbase = chainon (listbase, decl);
1477 decl = build_decl (FIELD_DECL, get_identifier ("lowindex"),
1478 long_unsigned_type_node);
1479 listbase = chainon (listbase, decl);
1480 decl = build_decl (FIELD_DECL, get_identifier ("highindex"),
1481 long_integer_type_node);
1482 listbase = chainon (listbase, decl);
1483 decl = build_decl (FIELD_DECL, get_identifier ("association"),
1485 listbase = chainon (listbase, decl);
1486 decl = build_decl (FIELD_DECL, get_identifier ("base"),
1487 long_unsigned_type_node);
1488 listbase = chainon (listbase, decl);
1489 decl = build_decl (FIELD_DECL, get_identifier ("storelocptr"),
1491 listbase = chainon (listbase, decl);
1492 decl = build_decl (FIELD_DECL, get_identifier ("rectype"),
1493 long_integer_type_node);
1494 listbase = chainon (listbase, decl);
1495 return build_chill_struct_type (listbase);
1499 build_access_mode (indexmode, recordmode, dynamic)
1504 tree type, listbase, decl, datamode;
1506 if (indexmode != NULL_TREE && TREE_CODE (indexmode) == ERROR_MARK)
1507 return error_mark_node;
1508 if (recordmode != NULL_TREE && TREE_CODE (recordmode) == ERROR_MARK)
1509 return error_mark_node;
1511 datamode = build_access_part ();
1513 type = make_node (RECORD_TYPE);
1514 listbase = build_decl (FIELD_DECL, get_identifier ("data"),
1516 TYPE_FIELDS (type) = listbase;
1517 decl = build_lang_decl (TYPE_DECL, get_identifier ("__recordmode"),
1518 recordmode == NULL_TREE ? void_type_node : recordmode);
1519 chainon (listbase, decl);
1520 decl = build_lang_decl (TYPE_DECL, get_identifier ("__indexmode"),
1521 indexmode == NULL_TREE ? void_type_node : indexmode);
1522 chainon (listbase, decl);
1523 decl = build_decl (CONST_DECL, get_identifier ("__dynamic"),
1525 DECL_INITIAL (decl) = dynamic ? integer_one_node : integer_zero_node;
1526 chainon (listbase, decl);
1527 CH_IS_ACCESS_MODE (type) = 1;
1528 CH_TYPE_NONVALUE_P (type) = 1;
1533 returns a structure like:
1534 STRUCT (txt STRUCT (flags ULONG,
1538 acc STRUCT (flags ULONG,
1546 tloc CHARS(textlength) VARYING;
1549 TYPE_DECL __indexmode indexmode ? indexmode : void_type_node
1550 CONST_DECL __text_length
1551 CONST_DECL __dynamic dynamic ? integer_one_node : integer_zero_node
1554 build_text_mode (textlength, indexmode, dynamic)
1559 tree txt, acc, listbase, decl, type, tltype;
1560 tree savedlength = textlength;
1562 if (indexmode != NULL_TREE && TREE_CODE (indexmode) == ERROR_MARK)
1563 return error_mark_node;
1564 if (textlength == NULL_TREE || TREE_CODE (textlength) == ERROR_MARK)
1565 return error_mark_node;
1567 /* build the structure */
1568 listbase = build_decl (FIELD_DECL, get_identifier ("flags"),
1569 long_unsigned_type_node);
1570 decl = build_decl (FIELD_DECL, get_identifier ("text_record"),
1572 listbase = chainon (listbase, decl);
1573 decl = build_decl (FIELD_DECL, get_identifier ("access_sub"),
1575 listbase = chainon (listbase, decl);
1576 decl = build_decl (FIELD_DECL, get_identifier ("actual_index"),
1577 long_integer_type_node);
1578 listbase = chainon (listbase, decl);
1579 txt = build_chill_struct_type (listbase);
1581 acc = build_access_part ();
1583 type = make_node (RECORD_TYPE);
1584 listbase = build_decl (FIELD_DECL, get_identifier ("txt"), txt);
1585 TYPE_FIELDS (type) = listbase;
1586 decl = build_decl (FIELD_DECL, get_identifier ("acc"), acc);
1587 chainon (listbase, decl);
1588 /* the text location */
1589 tltype = build_string_type (char_type_node, textlength);
1590 tltype = build_varying_struct (tltype);
1591 decl = build_decl (FIELD_DECL, get_identifier ("tloc"),
1593 chainon (listbase, decl);
1594 /* the index mode */
1595 decl = build_lang_decl (TYPE_DECL, get_identifier ("__indexmode"),
1596 indexmode == NULL_TREE ? void_type_node : indexmode);
1597 chainon (listbase, decl);
1599 decl = build_decl (CONST_DECL, get_identifier ("__textlength"),
1601 if (TREE_CODE (textlength) == COMPONENT_REF)
1602 /* FIXME: we cannot use one and the same COMPONENT_REF twice, so build
1604 savedlength = build_component_ref (TREE_OPERAND (textlength, 0),
1605 TREE_OPERAND (textlength, 1));
1606 DECL_INITIAL (decl) = savedlength;
1607 chainon (listbase, decl);
1609 decl = build_decl (CONST_DECL, get_identifier ("__dynamic"),
1611 DECL_INITIAL (decl) = dynamic ? integer_one_node : integer_zero_node;
1612 chainon (listbase, decl);
1613 CH_IS_TEXT_MODE (type) = 1;
1614 CH_TYPE_NONVALUE_P (type) = 1;
1619 check_text_length (length)
1622 if (length == NULL_TREE || TREE_CODE (length) == ERROR_MARK)
1624 if (TREE_TYPE (length) == NULL_TREE
1625 || !CH_SIMILAR (TREE_TYPE (length), integer_type_node))
1627 error ("non-integral text length");
1628 return integer_one_node;
1630 if (TREE_CODE (length) != INTEGER_CST)
1632 error ("non-constant text length");
1633 return integer_one_node;
1635 if (compare_int_csts (LE_EXPR, length, integer_zero_node))
1637 error ("text length must be greater then 0");
1638 return integer_one_node;
1644 text_indexmode (text)
1649 if (text == NULL_TREE || TREE_CODE (text) == ERROR_MARK)
1651 if (! CH_IS_TEXT_MODE (text))
1654 field = TYPE_FIELDS (text);
1655 for ( ; field != NULL_TREE; field = TREE_CHAIN (field))
1657 if (TREE_CODE (field) == TYPE_DECL)
1658 return TREE_TYPE (field);
1660 return void_type_node;
1669 if (text == NULL_TREE || TREE_CODE (text) == ERROR_MARK)
1671 if (! CH_IS_TEXT_MODE (text))
1674 field = TYPE_FIELDS (text);
1675 for ( ; field != NULL_TREE; field = TREE_CHAIN (field))
1677 if (TREE_CODE (field) == CONST_DECL &&
1678 DECL_NAME (field) == get_identifier ("__dynamic"))
1679 return DECL_INITIAL (field);
1681 return integer_zero_node;
1690 if (text == NULL_TREE || TREE_CODE (text) == ERROR_MARK)
1692 if (! CH_IS_TEXT_MODE (text))
1695 field = TYPE_FIELDS (text);
1696 for ( ; field != NULL_TREE; field = TREE_CHAIN (field))
1698 if (TREE_CODE (field) == CONST_DECL &&
1699 DECL_NAME (field) == get_identifier ("__textlength"))
1700 return DECL_INITIAL (field);
1702 return integer_zero_node;
1706 textlocation_mode (text)
1711 if (text == NULL_TREE || TREE_CODE (text) == ERROR_MARK)
1713 if (! CH_IS_TEXT_MODE (text))
1716 field = TYPE_FIELDS (text);
1717 for ( ; field != NULL_TREE; field = TREE_CHAIN (field))
1719 if (TREE_CODE (field) == FIELD_DECL &&
1720 DECL_NAME (field) == get_identifier ("tloc"))
1721 return TREE_TYPE (field);
1727 check_assoc (assoc, argnum, errmsg)
1732 if (assoc == NULL_TREE || TREE_CODE (assoc) == ERROR_MARK)
1735 if (! CH_IS_ASSOCIATION_MODE (TREE_TYPE (assoc)))
1737 error ("argument %d of %s must be of mode ASSOCIATION", argnum, errmsg);
1740 if (! CH_LOCATION_P (assoc))
1742 error ("argument %d of %s must be a location", argnum, errmsg);
1749 build_chill_associate (assoc, fname, attr)
1754 tree arg1 = NULL_TREE, arg2 = NULL_TREE, arg3 = NULL_TREE, arg4 = NULL_TREE,
1755 arg5 = NULL_TREE, arg6, arg7;
1759 /* make some checks */
1760 if (fname == NULL_TREE || TREE_CODE (fname) == ERROR_MARK)
1761 return error_mark_node;
1763 /* check the association */
1764 if (! check_assoc (assoc, 1, "ASSOCIATION"))
1767 /* build a pointer to the association */
1768 arg1 = force_addr_of (assoc);
1770 /* check the filename, must be a string */
1771 if (CH_CHARS_TYPE_P (TREE_TYPE (fname)) ||
1772 (flag_old_strings && TREE_CODE (fname) == INTEGER_CST &&
1773 TREE_CODE (TREE_TYPE (fname)) == CHAR_TYPE))
1775 if (int_size_in_bytes (TREE_TYPE (fname)) == 0)
1777 error ("argument 2 of ASSOCIATE must not be an empty string");
1782 arg2 = force_addr_of (fname);
1783 arg3 = size_in_bytes (TREE_TYPE (fname));
1786 else if (chill_varying_string_type_p (TREE_TYPE (fname)))
1788 arg2 = force_addr_of (build_component_ref (fname, var_data_id));
1789 arg3 = build_component_ref (fname, var_length_id);
1793 error ("argument 2 to ASSOCIATE must be a string");
1797 /* check attr argument, must be a string too */
1798 if (attr == NULL_TREE)
1800 arg4 = null_pointer_node;
1801 arg5 = integer_zero_node;
1805 attr = TREE_VALUE (attr);
1806 if (attr == NULL_TREE || TREE_CODE (attr) == ERROR_MARK)
1810 if (CH_CHARS_TYPE_P (TREE_TYPE (attr)) ||
1811 (flag_old_strings && TREE_CODE (attr) == INTEGER_CST &&
1812 TREE_CODE (TREE_TYPE (attr)) == CHAR_TYPE))
1814 if (int_size_in_bytes (TREE_TYPE (attr)) == 0)
1816 arg4 = null_pointer_node;
1817 arg5 = integer_zero_node;
1821 arg4 = force_addr_of (attr);
1822 arg5 = size_in_bytes (TREE_TYPE (attr));
1825 else if (chill_varying_string_type_p (TREE_TYPE (attr)))
1827 arg4 = force_addr_of (build_component_ref (attr, var_data_id));
1828 arg5 = build_component_ref (attr, var_length_id);
1832 error ("argument 3 to ASSOCIATE must be a string");
1839 return error_mark_node;
1841 /* other arguments */
1842 arg6 = force_addr_of (get_chill_filename ());
1843 arg7 = get_chill_linenumber ();
1845 result = build_chill_function_call (
1846 lookup_name (get_identifier ("__associate")),
1847 tree_cons (NULL_TREE, arg1,
1848 tree_cons (NULL_TREE, arg2,
1849 tree_cons (NULL_TREE, arg3,
1850 tree_cons (NULL_TREE, arg4,
1851 tree_cons (NULL_TREE, arg5,
1852 tree_cons (NULL_TREE, arg6,
1853 tree_cons (NULL_TREE, arg7, NULL_TREE))))))));
1855 TREE_TYPE (result) = build_chill_pointer_type (TREE_TYPE (assoc));
1860 assoc_call (assoc, func, name)
1865 tree arg1, arg2, arg3;
1868 if (! check_assoc (assoc, 1, name))
1869 return error_mark_node;
1871 arg1 = force_addr_of (assoc);
1872 arg2 = force_addr_of (get_chill_filename ());
1873 arg3 = get_chill_linenumber ();
1875 result = build_chill_function_call (func,
1876 tree_cons (NULL_TREE, arg1,
1877 tree_cons (NULL_TREE, arg2,
1878 tree_cons (NULL_TREE, arg3, NULL_TREE))));
1883 build_chill_isassociated (assoc)
1886 tree result = assoc_call (assoc,
1887 lookup_name (get_identifier ("__isassociated")),
1893 build_chill_existing (assoc)
1896 tree result = assoc_call (assoc,
1897 lookup_name (get_identifier ("__existing")),
1903 build_chill_readable (assoc)
1906 tree result = assoc_call (assoc,
1907 lookup_name (get_identifier ("__readable")),
1913 build_chill_writeable (assoc)
1916 tree result = assoc_call (assoc,
1917 lookup_name (get_identifier ("__writeable")),
1923 build_chill_sequencible (assoc)
1926 tree result = assoc_call (assoc,
1927 lookup_name (get_identifier ("__sequencible")),
1933 build_chill_variable (assoc)
1936 tree result = assoc_call (assoc,
1937 lookup_name (get_identifier ("__variable")),
1943 build_chill_indexable (assoc)
1946 tree result = assoc_call (assoc,
1947 lookup_name (get_identifier ("__indexable")),
1953 build_chill_dissociate (assoc)
1956 tree result = assoc_call (assoc,
1957 lookup_name (get_identifier ("__dissociate")),
1963 build_chill_create (assoc)
1966 tree result = assoc_call (assoc,
1967 lookup_name (get_identifier ("__create")),
1973 build_chill_delete (assoc)
1976 tree result = assoc_call (assoc,
1977 lookup_name (get_identifier ("__delete")),
1983 build_chill_modify (assoc, list)
1987 tree arg1 = NULL_TREE, arg2 = NULL_TREE, arg3 = NULL_TREE, arg4 = NULL_TREE,
1988 arg5 = NULL_TREE, arg6, arg7;
1989 int had_errors = 0, numargs;
1990 tree fname = NULL_TREE, attr = NULL_TREE;
1993 /* check the association */
1994 if (! check_assoc (assoc, 1, "MODIFY"))
1997 arg1 = force_addr_of (assoc);
1999 /* look how much arguments we have got */
2000 numargs = list_length (list);
2006 fname = TREE_VALUE (list);
2009 fname = TREE_VALUE (list);
2010 attr = TREE_VALUE (TREE_CHAIN (list));
2013 error ("Too many arguments in call to MODIFY");
2018 if (fname != NULL_TREE && fname != null_pointer_node)
2020 if (CH_CHARS_TYPE_P (TREE_TYPE (fname)) ||
2021 (flag_old_strings && TREE_CODE (fname) == INTEGER_CST &&
2022 TREE_CODE (TREE_TYPE (fname)) == CHAR_TYPE))
2024 if (int_size_in_bytes (TREE_TYPE (fname)) == 0)
2026 error ("argument 2 of MODIFY must not be an empty string");
2031 arg2 = force_addr_of (fname);
2032 arg3 = size_in_bytes (TREE_TYPE (fname));
2035 else if (chill_varying_string_type_p (TREE_TYPE (fname)))
2037 arg2 = force_addr_of (build_component_ref (fname, var_data_id));
2038 arg3 = build_component_ref (fname, var_length_id);
2042 error ("argument 2 to MODIFY must be a string");
2048 arg2 = null_pointer_node;
2049 arg3 = integer_zero_node;
2052 if (attr != NULL_TREE && attr != null_pointer_node)
2054 if (CH_CHARS_TYPE_P (TREE_TYPE (attr)) ||
2055 (flag_old_strings && TREE_CODE (attr) == INTEGER_CST &&
2056 TREE_CODE (TREE_TYPE (attr)) == CHAR_TYPE))
2058 if (int_size_in_bytes (TREE_TYPE (attr)) == 0)
2060 arg4 = null_pointer_node;
2061 arg5 = integer_zero_node;
2065 arg4 = force_addr_of (attr);
2066 arg5 = size_in_bytes (TREE_TYPE (attr));
2069 else if (chill_varying_string_type_p (TREE_TYPE (attr)))
2071 arg4 = force_addr_of (build_component_ref (attr, var_data_id));
2072 arg5 = build_component_ref (attr, var_length_id);
2076 error ("argument 3 to MODIFY must be a string");
2082 arg4 = null_pointer_node;
2083 arg5 = integer_zero_node;
2087 return error_mark_node;
2089 /* other arguments */
2090 arg6 = force_addr_of (get_chill_filename ());
2091 arg7 = get_chill_linenumber ();
2093 result = build_chill_function_call (
2094 lookup_name (get_identifier ("__modify")),
2095 tree_cons (NULL_TREE, arg1,
2096 tree_cons (NULL_TREE, arg2,
2097 tree_cons (NULL_TREE, arg3,
2098 tree_cons (NULL_TREE, arg4,
2099 tree_cons (NULL_TREE, arg5,
2100 tree_cons (NULL_TREE, arg6,
2101 tree_cons (NULL_TREE, arg7, NULL_TREE))))))));
2107 check_transfer (transfer, argnum, errmsg)
2114 if (transfer == NULL_TREE || TREE_CODE (transfer) == ERROR_MARK)
2117 if (CH_IS_ACCESS_MODE (TREE_TYPE (transfer)))
2119 else if (CH_IS_TEXT_MODE (TREE_TYPE (transfer)))
2123 error ("argument %d of %s must be an ACCESS or TEXT mode", argnum, errmsg);
2126 if (! CH_LOCATION_P (transfer))
2128 error ("argument %d of %s must be a location", argnum, errmsg);
2134 /* define bits in an access/text flag word.
2135 NOTE: this must be consistent with runtime/iomodes.h */
2136 #define IO_TEXTLOCATION 0x80000000
2137 #define IO_INDEXED 0x00000001
2138 #define IO_TEXTIO 0x00000002
2139 #define IO_OUTOFFILE 0x00010000
2141 /* generated initialisation code for ACCESS and TEXT.
2142 functions gets called from do_decl. */
2143 void init_access_location (decl, type)
2147 tree recordmode = access_recordmode (type);
2148 tree indexmode = access_indexmode (type);
2150 tree data = build_component_ref (decl, get_identifier ("data"));
2151 tree lowindex = integer_zero_node;
2152 tree highindex = integer_zero_node;
2153 tree rectype, reclen;
2156 if (indexmode != NULL_TREE && indexmode != void_type_node)
2158 flags_init |= IO_INDEXED;
2159 lowindex = convert (integer_type_node, TYPE_MIN_VALUE (indexmode));
2160 highindex = convert (integer_type_node, TYPE_MAX_VALUE (indexmode));
2164 build_chill_modify_expr (
2165 build_component_ref (data, get_identifier ("flags")),
2166 build_int_2 (flags_init, 0)));
2169 if (recordmode == NULL_TREE || recordmode == void_type_node)
2171 reclen = integer_zero_node;
2172 rectype = integer_zero_node;
2174 else if (chill_varying_string_type_p (recordmode))
2176 tree fields = TYPE_FIELDS (recordmode);
2179 /* don't count any padding bytes at end of varying */
2180 len1 = size_in_bytes (TREE_TYPE (fields));
2181 fields = TREE_CHAIN (fields);
2182 len2 = size_in_bytes (TREE_TYPE (fields));
2183 reclen = fold (build (PLUS_EXPR, long_integer_type_node, len1, len2));
2184 rectype = build_int_2 (2, 0);
2188 reclen = size_in_bytes (recordmode);
2189 rectype = integer_one_node;
2192 build_chill_modify_expr (
2193 build_component_ref (data, get_identifier ("reclength")), reclen));
2197 build_chill_modify_expr (
2198 build_component_ref (data, get_identifier ("rectype")), rectype));
2202 build_chill_modify_expr (
2203 build_component_ref (data, get_identifier ("lowindex")), lowindex));
2205 build_chill_modify_expr (
2206 build_component_ref (data, get_identifier ("highindex")), highindex));
2210 build_chill_modify_expr (
2211 build_chill_component_ref (data, get_identifier ("association")),
2212 null_pointer_node));
2216 build_chill_modify_expr (
2217 build_component_ref (data, get_identifier ("storelocptr")), null_pointer_node));
2220 void init_text_location (decl, type)
2224 tree indexmode = text_indexmode (type);
2225 unsigned long accessflags = 0;
2226 unsigned long textflags = IO_TEXTLOCATION;
2227 tree lowindex = integer_zero_node;
2228 tree highindex = integer_zero_node;
2229 tree data, tloc, tlocfields, len1, len2, reclen;
2231 if (indexmode != NULL_TREE && indexmode != void_type_node)
2233 accessflags |= IO_INDEXED;
2234 lowindex = convert (integer_type_node, TYPE_MIN_VALUE (indexmode));
2235 highindex = convert (integer_type_node, TYPE_MAX_VALUE (indexmode));
2238 tloc = build_component_ref (decl, get_identifier ("tloc"));
2239 /* fill access part of text location */
2240 data = build_component_ref (decl, get_identifier ("acc"));
2243 build_chill_modify_expr (
2244 build_component_ref (data, get_identifier ("flags")),
2245 build_int_2 (accessflags, 0)));
2247 /* record length, don't count any padding bytes at end of varying */
2248 tlocfields = TYPE_FIELDS (TREE_TYPE (tloc));
2249 len1 = size_in_bytes (TREE_TYPE (tlocfields));
2250 tlocfields = TREE_CHAIN (tlocfields);
2251 len2 = size_in_bytes (TREE_TYPE (tlocfields));
2252 reclen = fold (build (PLUS_EXPR, long_integer_type_node, len1, len2));
2254 build_chill_modify_expr (
2255 build_component_ref (data, get_identifier ("reclength")),
2260 build_chill_modify_expr (
2261 build_component_ref (data, get_identifier ("lowindex")), lowindex));
2263 build_chill_modify_expr (
2264 build_component_ref (data, get_identifier ("highindex")), highindex));
2268 build_chill_modify_expr (
2269 build_chill_component_ref (data, get_identifier ("association")),
2270 null_pointer_node));
2274 build_chill_modify_expr (
2275 build_component_ref (data, get_identifier ("storelocptr")),
2276 null_pointer_node));
2280 build_chill_modify_expr (
2281 build_component_ref (data, get_identifier ("rectype")),
2282 build_int_2 (2, 0))); /* VaryingChars */
2284 /* fill text part */
2285 data = build_component_ref (decl, get_identifier ("txt"));
2288 build_chill_modify_expr (
2289 build_component_ref (data, get_identifier ("flags")),
2290 build_int_2 (textflags, 0)));
2292 /* pointer to text record */
2294 build_chill_modify_expr (
2295 build_component_ref (data, get_identifier ("text_record")),
2296 force_addr_of (tloc)));
2298 /* pointer to the access */
2300 build_chill_modify_expr (
2301 build_component_ref (data, get_identifier ("access_sub")),
2302 force_addr_of (build_component_ref (decl, get_identifier ("acc")))));
2306 build_chill_modify_expr (
2307 build_component_ref (data, get_identifier ("actual_index")),
2308 integer_zero_node));
2310 /* length of text record */
2312 build_chill_modify_expr (
2313 build_component_ref (tloc, get_identifier (VAR_LENGTH)),
2314 integer_zero_node));
2318 connect_process_optionals (optionals, whereptr, indexptr, indexmode)
2324 tree where = NULL_TREE, theindex = NULL_TREE;
2327 if (optionals != NULL_TREE)
2329 /* get the where expression */
2330 where = TREE_VALUE (optionals);
2331 if (where == NULL_TREE || TREE_CODE (where) == ERROR_MARK)
2335 if (! CH_IS_WHERE_MODE (TREE_TYPE (where)))
2337 error ("argument 4 of CONNECT must be of mode WHERE");
2340 where = convert (integer_type_node, where);
2342 optionals = TREE_CHAIN (optionals);
2344 if (optionals != NULL_TREE)
2346 theindex = TREE_VALUE (optionals);
2347 if (theindex == NULL_TREE || TREE_CODE (theindex) == ERROR_MARK)
2351 if (indexmode == void_type_node)
2353 error ("index expression for ACCESS without index");
2356 else if (! CH_COMPATIBLE (theindex, indexmode))
2358 error ("incompatible index mode");
2367 *indexptr = theindex;
2372 connect_text (assoc, text, usage, optionals)
2378 tree where = NULL_TREE, theindex = NULL_TREE;
2379 tree indexmode = text_indexmode (TREE_TYPE (text));
2380 tree result, what_where, have_index, what_index;
2382 /* process optionals */
2383 if (!connect_process_optionals (optionals, &where, &theindex, indexmode))
2384 return error_mark_node;
2386 what_where = where == NULL_TREE ? integer_zero_node : where;
2387 have_index = theindex == NULL_TREE ? integer_zero_node
2389 what_index = theindex == NULL_TREE ? integer_zero_node
2390 : convert (integer_type_node, theindex);
2391 result = build_chill_function_call (
2392 lookup_name (get_identifier ("__connect")),
2393 tree_cons (NULL_TREE, force_addr_of (text),
2394 tree_cons (NULL_TREE, force_addr_of (assoc),
2395 tree_cons (NULL_TREE, convert (integer_type_node, usage),
2396 tree_cons (NULL_TREE, what_where,
2397 tree_cons (NULL_TREE, have_index,
2398 tree_cons (NULL_TREE, what_index,
2399 tree_cons (NULL_TREE, force_addr_of (get_chill_filename ()),
2400 tree_cons (NULL_TREE, get_chill_linenumber (),
2406 connect_access (assoc, transfer, usage, optionals)
2412 tree where = NULL_TREE, theindex = NULL_TREE;
2413 tree indexmode = access_indexmode (TREE_TYPE (transfer));
2414 tree result, what_where, have_index, what_index;
2416 /* process the optionals */
2417 if (! connect_process_optionals (optionals, &where, &theindex, indexmode))
2418 return error_mark_node;
2421 what_where = where == NULL_TREE ? integer_zero_node : where;
2422 have_index = theindex == NULL_TREE ? integer_zero_node : integer_one_node;
2423 what_index = theindex == NULL_TREE ? integer_zero_node : convert (integer_type_node, theindex);
2424 result = build_chill_function_call (
2425 lookup_name (get_identifier ("__connect")),
2426 tree_cons (NULL_TREE, force_addr_of (transfer),
2427 tree_cons (NULL_TREE, force_addr_of (assoc),
2428 tree_cons (NULL_TREE, convert (integer_type_node, usage),
2429 tree_cons (NULL_TREE, what_where,
2430 tree_cons (NULL_TREE, have_index,
2431 tree_cons (NULL_TREE, what_index,
2432 tree_cons (NULL_TREE, force_addr_of (get_chill_filename ()),
2433 tree_cons (NULL_TREE, get_chill_linenumber (),
2439 build_chill_connect (transfer, assoc, usage, optionals)
2447 tree result = error_mark_node;
2449 if (! check_assoc (assoc, 2, "CONNECT"))
2453 if (usage == NULL_TREE || TREE_CODE (usage) == ERROR_MARK)
2454 return error_mark_node;
2456 if (! CH_IS_USAGE_MODE (TREE_TYPE (usage)))
2458 error ("argument 3 to CONNECT must be of mode USAGE");
2462 return error_mark_node;
2464 /* look what we have got */
2465 what = check_transfer (transfer, 1, "CONNECT");
2469 /* we have an ACCESS */
2470 result = connect_access (assoc, transfer, usage, optionals);
2473 /* we have a TEXT */
2474 result = connect_text (assoc, transfer, usage, optionals);
2477 result = error_mark_node;
2483 check_access (access, argnum, errmsg)
2488 if (access == NULL_TREE || TREE_CODE (access) == ERROR_MARK)
2491 if (! CH_IS_ACCESS_MODE (TREE_TYPE (access)))
2493 error ("argument %d of %s must be of mode ACCESS", argnum, errmsg);
2496 if (! CH_LOCATION_P (access))
2498 error ("argument %d of %s must be a location", argnum, errmsg);
2505 build_chill_readrecord (access, optionals)
2510 tree recordmode, indexmode, dynamic, result;
2511 tree index = NULL_TREE, location = NULL_TREE;
2513 if (! check_access (access, 1, "READRECORD"))
2514 return error_mark_node;
2516 recordmode = access_recordmode (TREE_TYPE (access));
2517 indexmode = access_indexmode (TREE_TYPE (access));
2518 dynamic = access_dynamic (TREE_TYPE (access));
2520 /* process the optionals */
2521 len = list_length (optionals);
2522 if (indexmode != void_type_node)
2524 /* we must have an index */
2527 error ("Too few arguments in call to `readrecord'");
2528 return error_mark_node;
2530 index = TREE_VALUE (optionals);
2531 if (index == NULL_TREE || TREE_CODE (index) == ERROR_MARK)
2532 return error_mark_node;
2533 optionals = TREE_CHAIN (optionals);
2534 if (! CH_COMPATIBLE (index, indexmode))
2536 error ("incompatible index mode");
2537 return error_mark_node;
2541 /* check the record mode, if one */
2542 if (optionals != NULL_TREE)
2544 location = TREE_VALUE (optionals);
2545 if (location == NULL_TREE || TREE_CODE (location) == ERROR_MARK)
2546 return error_mark_node;
2547 if (recordmode != void_type_node &&
2548 ! CH_COMPATIBLE (location, recordmode))
2551 error ("incompatible record mode");
2552 return error_mark_node;
2554 if (TYPE_READONLY_PROPERTY (TREE_TYPE (location)))
2556 error ("store location must not be READonly");
2557 return error_mark_node;
2559 location = force_addr_of (location);
2562 location = null_pointer_node;
2564 index = index == NULL_TREE ? integer_zero_node : convert (integer_type_node, index);
2565 result = build_chill_function_call (
2566 lookup_name (get_identifier ("__readrecord")),
2567 tree_cons (NULL_TREE, force_addr_of (access),
2568 tree_cons (NULL_TREE, index,
2569 tree_cons (NULL_TREE, location,
2570 tree_cons (NULL_TREE, force_addr_of (get_chill_filename ()),
2571 tree_cons (NULL_TREE, get_chill_linenumber (), NULL_TREE))))));
2573 TREE_TYPE (result) = build_chill_pointer_type (recordmode);
2578 build_chill_writerecord (access, optionals)
2582 int had_errors = 0, len;
2583 tree recordmode, indexmode, dynamic;
2584 tree index = NULL_TREE, location = NULL_TREE;
2587 if (! check_access (access, 1, "WRITERECORD"))
2588 return error_mark_node;
2590 recordmode = access_recordmode (TREE_TYPE (access));
2591 indexmode = access_indexmode (TREE_TYPE (access));
2592 dynamic = access_dynamic (TREE_TYPE (access));
2594 /* process the optionals */
2595 len = list_length (optionals);
2596 if (indexmode != void_type_node && len != 2)
2598 error ("Too few arguments in call to `writerecord'");
2599 return error_mark_node;
2601 if (indexmode != void_type_node)
2603 index = TREE_VALUE (optionals);
2604 if (index == NULL_TREE || TREE_CODE (index) == ERROR_MARK)
2605 return error_mark_node;
2606 location = TREE_VALUE (TREE_CHAIN (optionals));
2607 if (location == NULL_TREE || TREE_CODE (location) == ERROR_MARK)
2608 return error_mark_node;
2611 location = TREE_VALUE (optionals);
2613 /* check the index */
2614 if (indexmode != void_type_node)
2616 if (! CH_COMPATIBLE (index, indexmode))
2618 error ("incompatible index mode");
2622 /* check the record mode */
2623 if (recordmode == void_type_node)
2625 error ("transfer to ACCESS without record mode");
2628 else if (! CH_COMPATIBLE (location, recordmode))
2630 error ("incompatible record mode");
2634 return error_mark_node;
2636 index = index == NULL_TREE ? integer_zero_node : convert (integer_type_node, index);
2638 result = build_chill_function_call (
2639 lookup_name (get_identifier ("__writerecord")),
2640 tree_cons (NULL_TREE, force_addr_of (access),
2641 tree_cons (NULL_TREE, index,
2642 tree_cons (NULL_TREE, force_addr_of (location),
2643 tree_cons (NULL_TREE, size_in_bytes (TREE_TYPE (location)),
2644 tree_cons (NULL_TREE, force_addr_of (get_chill_filename ()),
2645 tree_cons (NULL_TREE, get_chill_linenumber (), NULL_TREE)))))));
2650 build_chill_disconnect (transfer)
2655 if (! check_transfer (transfer, 1, "DISCONNECT"))
2656 return error_mark_node;
2657 result = build_chill_function_call (
2658 lookup_name (get_identifier ("__disconnect")),
2659 tree_cons (NULL_TREE, force_addr_of (transfer),
2660 tree_cons (NULL_TREE, force_addr_of (get_chill_filename ()),
2661 tree_cons (NULL_TREE, get_chill_linenumber (), NULL_TREE))));
2666 build_chill_getassociation (transfer)
2671 if (! check_transfer (transfer, 1, "GETASSOCIATION"))
2672 return error_mark_node;
2674 result = build_chill_function_call (
2675 lookup_name (get_identifier ("__getassociation")),
2676 tree_cons (NULL_TREE, force_addr_of (transfer),
2677 tree_cons (NULL_TREE, force_addr_of (get_chill_filename ()),
2678 tree_cons (NULL_TREE, get_chill_linenumber (), NULL_TREE))));
2679 TREE_TYPE (result) = build_chill_pointer_type (association_type_node);
2684 build_chill_getusage (transfer)
2689 if (! check_transfer (transfer, 1, "GETUSAGE"))
2690 return error_mark_node;
2692 result = build_chill_function_call (
2693 lookup_name (get_identifier ("__getusage")),
2694 tree_cons (NULL_TREE, force_addr_of (transfer),
2695 tree_cons (NULL_TREE, force_addr_of (get_chill_filename ()),
2696 tree_cons (NULL_TREE, get_chill_linenumber (), NULL_TREE))));
2697 TREE_TYPE (result) = usage_type_node;
2702 build_chill_outoffile (transfer)
2707 if (! check_transfer (transfer, 1, "OUTOFFILE"))
2708 return error_mark_node;
2710 result = build_chill_function_call (
2711 lookup_name (get_identifier ("__outoffile")),
2712 tree_cons (NULL_TREE, force_addr_of (transfer),
2713 tree_cons (NULL_TREE, force_addr_of (get_chill_filename ()),
2714 tree_cons (NULL_TREE, get_chill_linenumber (), NULL_TREE))));
2719 check_text (text, argnum, errmsg)
2724 if (text == NULL_TREE || TREE_CODE (text) == ERROR_MARK)
2726 if (! CH_IS_TEXT_MODE (TREE_TYPE (text)))
2728 error ("argument %d of %s must be of mode TEXT", argnum, errmsg);
2731 if (! CH_LOCATION_P (text))
2733 error ("argument %d of %s must be a location", argnum, errmsg);
2740 build_chill_eoln (text)
2745 if (! check_text (text, 1, "EOLN"))
2746 return error_mark_node;
2748 result = build_chill_function_call (
2749 lookup_name (get_identifier ("__eoln")),
2750 tree_cons (NULL_TREE, force_addr_of (text),
2751 tree_cons (NULL_TREE, force_addr_of (get_chill_filename ()),
2752 tree_cons (NULL_TREE, get_chill_linenumber (), NULL_TREE))));
2757 build_chill_gettextindex (text)
2762 if (! check_text (text, 1, "GETTEXTINDEX"))
2763 return error_mark_node;
2765 result = build_chill_function_call (
2766 lookup_name (get_identifier ("__gettextindex")),
2767 tree_cons (NULL_TREE, force_addr_of (text),
2768 tree_cons (NULL_TREE, force_addr_of (get_chill_filename ()),
2769 tree_cons (NULL_TREE, get_chill_linenumber (), NULL_TREE))));
2774 build_chill_gettextrecord (text)
2777 tree textmode, result;
2779 if (! check_text (text, 1, "GETTEXTRECORD"))
2780 return error_mark_node;
2782 textmode = textlocation_mode (TREE_TYPE (text));
2783 if (textmode == NULL_TREE)
2785 error ("TEXT doesn't have a location"); /* FIXME */
2786 return error_mark_node;
2788 result = build_chill_function_call (
2789 lookup_name (get_identifier ("__gettextrecord")),
2790 tree_cons (NULL_TREE, force_addr_of (text),
2791 tree_cons (NULL_TREE, force_addr_of (get_chill_filename ()),
2792 tree_cons (NULL_TREE, get_chill_linenumber (), NULL_TREE))));
2793 TREE_TYPE (result) = build_chill_pointer_type (textmode);
2794 CH_DERIVED_FLAG (result) = 1;
2799 build_chill_gettextaccess (text)
2802 tree access, refaccess, acc, decl, listbase;
2803 tree tlocmode, indexmode, dynamic;
2805 extern int maximum_field_alignment;
2806 int save_maximum_field_alignment = maximum_field_alignment;
2808 if (! check_text (text, 1, "GETTEXTACCESS"))
2809 return error_mark_node;
2811 tlocmode = textlocation_mode (TREE_TYPE (text));
2812 indexmode = text_indexmode (TREE_TYPE (text));
2813 dynamic = text_dynamic (TREE_TYPE (text));
2815 /* we have to build a type for the access */
2816 acc = build_access_part ();
2817 access = make_node (RECORD_TYPE);
2818 listbase = build_decl (FIELD_DECL, get_identifier ("data"), acc);
2819 TYPE_FIELDS (access) = listbase;
2820 decl = build_lang_decl (TYPE_DECL, get_identifier ("__recordmode"),
2822 chainon (listbase, decl);
2823 decl = build_lang_decl (TYPE_DECL, get_identifier ("__indexmode"),
2825 chainon (listbase, decl);
2826 decl = build_decl (CONST_DECL, get_identifier ("__dynamic"),
2828 DECL_INITIAL (decl) = dynamic;
2829 chainon (listbase, decl);
2830 maximum_field_alignment = 0;
2831 layout_chill_struct_type (access);
2832 maximum_field_alignment = save_maximum_field_alignment;
2833 CH_IS_ACCESS_MODE (access) = 1;
2834 CH_TYPE_NONVALUE_P (access) = 1;
2836 refaccess = build_chill_pointer_type (access);
2838 result = build_chill_function_call (
2839 lookup_name (get_identifier ("__gettextaccess")),
2840 tree_cons (NULL_TREE, force_addr_of (text),
2841 tree_cons (NULL_TREE, force_addr_of (get_chill_filename ()),
2842 tree_cons (NULL_TREE, get_chill_linenumber (), NULL_TREE))));
2843 TREE_TYPE (result) = refaccess;
2844 CH_DERIVED_FLAG (result) = 1;
2849 build_chill_settextindex (text, expr)
2855 if (! check_text (text, 1, "SETTEXTINDEX"))
2856 return error_mark_node;
2857 if (expr == NULL_TREE || TREE_CODE (expr) == ERROR_MARK)
2858 return error_mark_node;
2859 result = build_chill_function_call (
2860 lookup_name (get_identifier ("__settextindex")),
2861 tree_cons (NULL_TREE, force_addr_of (text),
2862 tree_cons (NULL_TREE, expr,
2863 tree_cons (NULL_TREE, force_addr_of (get_chill_filename ()),
2864 tree_cons (NULL_TREE, get_chill_linenumber (), NULL_TREE)))));
2869 build_chill_settextaccess (text, access)
2874 tree textindexmode, accessindexmode;
2875 tree textrecordmode, accessrecordmode;
2877 if (! check_text (text, 1, "SETTEXTACCESS"))
2878 return error_mark_node;
2879 if (! check_access (access, 2, "SETTEXTACCESS"))
2880 return error_mark_node;
2882 textindexmode = text_indexmode (TREE_TYPE (text));
2883 accessindexmode = access_indexmode (TREE_TYPE (access));
2884 if (textindexmode != accessindexmode)
2886 if (! chill_read_compatible (textindexmode, accessindexmode))
2888 error ("incompatible index mode for SETETEXTACCESS");
2889 return error_mark_node;
2892 textrecordmode = textlocation_mode (TREE_TYPE (text));
2893 accessrecordmode = access_recordmode (TREE_TYPE (access));
2894 if (textrecordmode != accessrecordmode)
2896 if (! chill_read_compatible (textrecordmode, accessrecordmode))
2898 error ("incompatible record mode for SETTEXTACCESS");
2899 return error_mark_node;
2902 result = build_chill_function_call (
2903 lookup_name (get_identifier ("__settextaccess")),
2904 tree_cons (NULL_TREE, force_addr_of (text),
2905 tree_cons (NULL_TREE, force_addr_of (access),
2906 tree_cons (NULL_TREE, force_addr_of (get_chill_filename ()),
2907 tree_cons (NULL_TREE, get_chill_linenumber (), NULL_TREE)))));
2912 build_chill_settextrecord (text, charloc)
2920 if (! check_text (text, 1, "SETTEXTRECORD"))
2921 return error_mark_node;
2922 if (charloc == NULL_TREE || TREE_CODE (charloc) == ERROR_MARK)
2923 return error_mark_node;
2925 /* check the location */
2926 if (! CH_LOCATION_P (charloc))
2928 error ("parameter 2 must be a location");
2929 return error_mark_node;
2931 tlocmode = textlocation_mode (TREE_TYPE (text));
2932 if (! chill_varying_string_type_p (TREE_TYPE (charloc)))
2934 else if (int_size_in_bytes (tlocmode) != int_size_in_bytes (TREE_TYPE (charloc)))
2938 error ("incompatible modes in parameter 2");
2939 return error_mark_node;
2941 result = build_chill_function_call (
2942 lookup_name (get_identifier ("__settextrecord")),
2943 tree_cons (NULL_TREE, force_addr_of (text),
2944 tree_cons (NULL_TREE, force_addr_of (charloc),
2945 tree_cons (NULL_TREE, force_addr_of (get_chill_filename ()),
2946 tree_cons (NULL_TREE, get_chill_linenumber (), NULL_TREE)))));
2950 /* process iolist for READ- and WRITETEXT */
2952 /* function walks through types as long as they are ranges,
2953 returns the type and min- and max-value form starting type.
2957 get_final_type_and_range (item, low, high)
2964 *low = TYPE_MIN_VALUE (wrk);
2965 *high = TYPE_MAX_VALUE (wrk);
2966 while (TREE_CODE (wrk) == INTEGER_TYPE &&
2967 TREE_TYPE (wrk) != NULL_TREE &&
2968 TREE_CODE (TREE_TYPE (wrk)) == INTEGER_TYPE &&
2969 TREE_TYPE (TREE_TYPE (wrk)) != NULL_TREE)
2970 wrk = TREE_TYPE (wrk);
2972 return (TREE_TYPE (wrk));
2976 process_io_list (exprlist, iolist_addr, iolist_length, iolist_rtx, do_read,
2980 tree *iolist_length;
2988 tree iolisttype, iolist;
2990 if (exprlist == NULL_TREE)
2993 iolen = list_length (exprlist);
2995 /* build indexlist for the io list */
2996 idxlist = build_tree_list (NULL_TREE,
2997 build_chill_range_type (NULL_TREE,
2999 build_int_2 (iolen, 0)));
3001 /* build the io-list type */
3002 iolisttype = build_chill_array_type (TREE_TYPE (chill_io_list_type),
3003 idxlist, 0, NULL_TREE);
3005 /* declare the iolist */
3006 iolist = build_decl (VAR_DECL, get_unique_identifier (do_read ? "RDTEXT" : "WRTEXT"),
3009 /* we want to get a variable which gets marked unused after
3010 the function call, This is a little bit tricky cause the
3011 address of this variable will be taken and therefor the variable
3012 gets moved out one level. However, we REALLY don't need this
3013 variable again. Solution: push 2 levels and do pop and free
3014 twice at the end. */
3017 *iolist_rtx = assign_temp (TREE_TYPE (iolist), 0, 1, 0);
3018 DECL_RTL (iolist) = *iolist_rtx;
3020 /* process the exprlist */
3022 while (exprlist != NULL_TREE)
3024 tree item = TREE_VALUE (exprlist);
3025 tree idx = build_int_2 (idxcnt++, 0);
3026 char *fieldname = 0;
3028 tree array_ref = build_chill_array_ref_1 (iolist, idx);
3030 tree range_low = NULL_TREE, range_high = NULL_TREE;
3032 tree item_addr = null_pointer_node;
3036 /* next value in exprlist */
3037 exprlist = TREE_CHAIN (exprlist);
3038 if (item == NULL_TREE || TREE_CODE (item) == ERROR_MARK)
3041 item_type = TREE_TYPE (item);
3042 if (item_type == NULL_TREE)
3044 if (TREE_CODE (item) == COND_EXPR || TREE_CODE (item) == CASE_EXPR)
3045 error ("conditional expression not allowed in this context");
3047 error ("untyped expression as argument %d", idxcnt + 1 + argoffset);
3050 else if (TREE_CODE (item_type) == ERROR_MARK)
3053 if (TREE_CODE (item_type) == REFERENCE_TYPE)
3055 item_type = TREE_TYPE (item_type);
3056 item = convert (item_type, item);
3059 /* check for a range */
3060 if (TREE_CODE (item_type) == INTEGER_TYPE &&
3061 TREE_TYPE (item_type) != NULL_TREE)
3063 /* we have a range. NOTE, however, on writetext we don't process ranges */
3064 item_type = get_final_type_and_range (item_type,
3065 &range_low, &range_high);
3069 readonly = TYPE_READONLY_PROPERTY (item_type);
3070 referable = CH_REFERABLE (item);
3072 item_addr = force_addr_of (item);
3073 /* if we are in read and have readonly we can't do this */
3074 if (readonly && do_read)
3076 item_addr = null_pointer_node;
3080 /* process different types */
3081 if (TREE_CODE (item_type) == INTEGER_TYPE)
3083 int type_size = TREE_INT_CST_LOW (TYPE_SIZE (item_type));
3084 tree to_assign = NULL_TREE;
3086 if (do_read && referable)
3088 /* process an integer in case of READTEXT and expression is
3089 referable and not READONLY */
3090 to_assign = item_addr;
3093 /* do it for a range */
3094 tree t, __forxx, __ptr, __low, __high;
3095 tree what_upper, what_lower;
3097 /* determine the name in the union of lower and upper */
3098 if (TREE_UNSIGNED (item_type))
3099 fieldname = "_ulong";
3101 fieldname = "_slong";
3106 if (TREE_UNSIGNED (item_type))
3107 enumname = "__IO_UByteRangeLoc";
3109 enumname = "__IO_ByteRangeLoc";
3112 if (TREE_UNSIGNED (item_type))
3113 enumname = "__IO_UIntRangeLoc";
3115 enumname = "__IO_IntRangeLoc";
3118 if (TREE_UNSIGNED (item_type))
3119 enumname = "__IO_ULongRangeLoc";
3121 enumname = "__IO_LongRangeLoc";
3124 error ("Cannot process %d bits integer for READTEXT argument %d.",
3125 type_size, idxcnt + 1 + argoffset);
3129 /* set up access to structure */
3130 t = build_component_ref (array_ref,
3131 get_identifier ("__t"));
3132 __forxx = build_component_ref (t, get_identifier ("__locintrange"));
3133 __ptr = build_component_ref (__forxx, get_identifier ("ptr"));
3134 __low = build_component_ref (__forxx, get_identifier ("lower"));
3135 what_lower = build_component_ref (__low, get_identifier (fieldname));
3136 __high = build_component_ref (__forxx, get_identifier ("upper"));
3137 what_upper = build_component_ref (__high, get_identifier (fieldname));
3139 /* do the assignments */
3140 expand_assignment (__ptr, item_addr, 0, 0);
3141 expand_assignment (what_lower, range_low, 0, 0);
3142 expand_assignment (what_upper, range_high, 0, 0);
3148 fieldname = "__locint";
3152 if (TREE_UNSIGNED (item_type))
3153 enumname = "__IO_UByteLoc";
3155 enumname = "__IO_ByteLoc";
3158 if (TREE_UNSIGNED (item_type))
3159 enumname = "__IO_UIntLoc";
3161 enumname = "__IO_IntLoc";
3164 if (TREE_UNSIGNED (item_type))
3165 enumname = "__IO_ULongLoc";
3167 enumname = "__IO_LongLoc";
3170 error ("Cannot process %d bits integer for READTEXT argument %d.",
3171 type_size, idxcnt + 1 + argoffset);
3178 /* process an integer in case of WRITETEXT */
3183 if (TREE_UNSIGNED (item_type))
3185 enumname = "__IO_UByteVal";
3186 fieldname = "__valubyte";
3190 enumname = "__IO_ByteVal";
3191 fieldname = "__valbyte";
3195 if (TREE_UNSIGNED (item_type))
3197 enumname = "__IO_UIntVal";
3198 fieldname = "__valuint";
3202 enumname = "__IO_IntVal";
3203 fieldname = "__valint";
3208 if (TREE_UNSIGNED (item_type))
3210 enumname = "__IO_ULongVal";
3211 fieldname = "__valulong";
3215 enumname = "__IO_LongVal";
3216 fieldname = "__vallong";
3220 /* convert it back to {unsigned}long. */
3221 if (TREE_UNSIGNED (item_type))
3222 item_type = long_unsigned_type_node;
3224 item_type = long_integer_type_node;
3225 item = convert (item_type, item);
3228 /* This kludge is because the lexer gives literals
3229 the type long_long_{integer,unsigned}_type_node. */
3230 if (TREE_CODE (item) == INTEGER_CST)
3232 if (int_fits_type_p (item, long_integer_type_node))
3234 item_type = long_integer_type_node;
3235 item = convert (item_type, item);
3238 if (int_fits_type_p (item, long_unsigned_type_node))
3240 item_type = long_unsigned_type_node;
3241 item = convert (item_type, item);
3245 error ("Cannot process %d bits integer WRITETEXT argument %d.",
3246 type_size, idxcnt + 1 + argoffset);
3254 t = build_component_ref (array_ref,
3255 get_identifier ("__t"));
3256 __forxx = build_component_ref (t, get_identifier (fieldname));
3257 expand_assignment (__forxx, to_assign, 0, 0);
3260 else if (TREE_CODE (item_type) == CHAR_TYPE)
3262 tree to_assign = NULL_TREE;
3264 if (do_read && readonly)
3266 error ("argument %d is READonly", idxcnt + 1 + argoffset);
3273 error ("argument %d must be referable", idxcnt + 1 + argoffset);
3278 tree t, forxx, ptr, lower, upper;
3280 t = build_component_ref (array_ref, get_identifier ("__t"));
3281 forxx = build_component_ref (t, get_identifier ("__loccharrange"));
3282 ptr = build_component_ref (forxx, get_identifier ("ptr"));
3283 lower = build_component_ref (forxx, get_identifier ("lower"));
3284 upper = build_component_ref (forxx, get_identifier ("upper"));
3285 expand_assignment (ptr, item_addr, 0, 0);
3286 expand_assignment (lower, range_low, 0, 0);
3287 expand_assignment (upper, range_high, 0, 0);
3290 enumname = "__IO_CharRangeLoc";
3294 to_assign = item_addr;
3295 fieldname = "__locchar";
3296 enumname = "__IO_CharLoc";
3302 enumname = "__IO_CharVal";
3303 fieldname = "__valchar";
3310 t = build_component_ref (array_ref, get_identifier ("__t"));
3311 forxx = build_component_ref (t, get_identifier (fieldname));
3312 expand_assignment (forxx, to_assign, 0, 0);
3315 else if (TREE_CODE (item_type) == BOOLEAN_TYPE)
3319 if (do_read && readonly)
3321 error ("argument %d is READonly", idxcnt + 1 + argoffset);
3328 error ("argument %d must be referable", idxcnt + 1 + argoffset);
3333 tree t, forxx, ptr, lower, upper;
3335 t = build_component_ref (array_ref, get_identifier ("__t"));
3336 forxx = build_component_ref (t, get_identifier ("__locboolrange"));
3337 ptr = build_component_ref (forxx, get_identifier ("ptr"));
3338 lower = build_component_ref (forxx, get_identifier ("lower"));
3339 upper = build_component_ref (forxx, get_identifier ("upper"));
3340 expand_assignment (ptr, item_addr, 0, 0);
3341 expand_assignment (lower, range_low, 0, 0);
3342 expand_assignment (upper, range_high, 0, 0);
3345 enumname = "__IO_BoolRangeLoc";
3349 to_assign = item_addr;
3350 fieldname = "__locbool";
3351 enumname = "__IO_BoolLoc";
3357 enumname = "__IO_BoolVal";
3358 fieldname = "__valbool";
3364 t = build_component_ref (array_ref, get_identifier ("__t"));
3365 forxx = build_component_ref (t, get_identifier (fieldname));
3366 expand_assignment (forxx, to_assign, 0, 0);
3369 else if (TREE_CODE (item_type) == ENUMERAL_TYPE)
3371 /* process an enum */
3373 tree context_of_type;
3376 /* determine the context of the type.
3377 if TYPE_NAME (item_type) == NULL_TREE
3378 if TREE_CODE (item) == INTEGER_CST
3379 context = NULL_TREE -- this is wrong but should work for now
3381 context = DECL_CONTEXT (item)
3383 context = DECL_CONTEXT (TYPE_NAME (item_type)) */
3385 if (TYPE_NAME (item_type) == NULL_TREE)
3387 if (TREE_CODE (item) == INTEGER_CST)
3388 context_of_type = NULL_TREE;
3390 context_of_type = DECL_CONTEXT (item);
3393 context_of_type = DECL_CONTEXT (TYPE_NAME (item_type));
3395 table_name = add_enum_to_list (item_type, context_of_type);
3396 t = build_component_ref (array_ref, get_identifier ("__t"));
3398 if (do_read && readonly)
3400 error ("argument %d is READonly", idxcnt + 1 + argoffset);
3407 error ("argument %d must be referable", idxcnt + 1 + argoffset);
3412 tree forxx, ptr, len, nametable, lower, upper;
3414 forxx = build_component_ref (t, get_identifier ("__locsetrange"));
3415 ptr = build_component_ref (forxx, get_identifier ("ptr"));
3416 len = build_component_ref (forxx, get_identifier ("length"));
3417 nametable = build_component_ref (forxx, get_identifier ("name_table"));
3418 lower = build_component_ref (forxx, get_identifier ("lower"));
3419 upper = build_component_ref (forxx, get_identifier ("upper"));
3420 expand_assignment (ptr, item_addr, 0, 0);
3421 expand_assignment (len, size_in_bytes (item_type), 0, 0);
3422 expand_assignment (nametable, table_name, 0, 0);
3423 expand_assignment (lower, range_low, 0, 0);
3424 expand_assignment (upper, range_high, 0, 0);
3426 enumname = "__IO_SetRangeLoc";
3430 tree forxx, ptr, len, nametable;
3432 forxx = build_component_ref (t, get_identifier ("__locset"));
3433 ptr = build_component_ref (forxx, get_identifier ("ptr"));
3434 len = build_component_ref (forxx, get_identifier ("length"));
3435 nametable = build_component_ref (forxx, get_identifier ("name_table"));
3436 expand_assignment (ptr, item_addr, 0, 0);
3437 expand_assignment (len, size_in_bytes (item_type), 0, 0);
3438 expand_assignment (nametable, table_name, 0, 0);
3440 enumname = "__IO_SetLoc";
3445 tree forxx, value, nametable;
3447 forxx = build_component_ref (t, get_identifier ("__valset"));
3448 value = build_component_ref (forxx, get_identifier ("value"));
3449 nametable = build_component_ref (forxx, get_identifier ("name_table"));
3450 expand_assignment (value, item, 0, 0);
3451 expand_assignment (nametable, table_name, 0, 0);
3453 enumname = "__IO_SetVal";
3456 else if (chill_varying_string_type_p (item_type))
3458 /* varying char string */
3459 tree t = build_component_ref (array_ref, get_identifier ("__t"));
3460 tree forxx = build_component_ref (t, get_identifier ("__loccharstring"));
3461 tree string = build_component_ref (forxx, get_identifier ("string"));
3462 tree length = build_component_ref (forxx, get_identifier ("string_length"));
3464 if (do_read && readonly)
3466 error ("argument %d is READonly", idxcnt + 1 + argoffset);
3471 /* in this read case the argument must be referable */
3474 error ("argument %d must be referable", idxcnt + 1 + argoffset);
3478 else if (! referable)
3480 /* in the write case we create a temporary if not referable */
3482 tree loc = build_decl (VAR_DECL,
3483 get_unique_identifier ("WRTEXTVS"),
3485 t = assign_temp (item_type, 0, 1, 0);
3487 expand_assignment (loc, item, 0, 0);
3488 item_addr = force_addr_of (loc);
3492 expand_assignment (string, item_addr, 0, 0);
3494 /* we must pass the maximum length of the varying */
3495 expand_assignment (length,
3496 size_in_bytes (TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (item_type)))),
3499 /* we pass the actual length of the string */
3500 expand_assignment (length,
3501 build_component_ref (item, var_length_id),
3504 enumname = "__IO_CharVaryingLoc";
3506 else if (CH_CHARS_TYPE_P (item_type))
3508 /* fixed character string */
3510 tree t = build_component_ref (array_ref, get_identifier ("__t"));
3511 tree forxx = build_component_ref (t, get_identifier ("__loccharstring"));
3512 tree string = build_component_ref (forxx, get_identifier ("string"));
3513 tree length = build_component_ref (forxx, get_identifier ("string_length"));
3515 if (do_read && readonly)
3517 error ("argument %d is READonly", idxcnt + 1 + argoffset);
3522 /* in this read case the argument must be referable */
3523 if (! CH_REFERABLE (item))
3525 error ("argument %d must be referable", idxcnt + 1 + argoffset);
3529 item_addr = force_addr_of (item);
3530 the_size = size_in_bytes (item_type);
3531 enumname = "__IO_CharStrLoc";
3535 if (! CH_REFERABLE (item))
3537 /* in the write case we create a temporary if not referable */
3541 howmuchbytes = int_size_in_bytes (item_type);
3542 if (howmuchbytes != -1)
3545 tree loc = build_decl (VAR_DECL,
3546 get_unique_identifier ("WRTEXTVS"),
3548 t = assign_temp (item_type, 0, 1, 0);
3550 expand_assignment (loc, item, 0, 0);
3551 item_addr = force_addr_of (loc);
3552 the_size = size_in_bytes (item_type);
3553 enumname = "__IO_CharStrLoc";
3557 tree type, string, exp, loc;
3559 if ((howmuchbytes = intsize_of_charsexpr (item)) == -1)
3561 error ("cannot process argument %d of WRITETEXT, unknown size",
3562 idxcnt + 1 + argoffset);
3565 string = build_string_type (char_type_node,
3566 build_int_2 (howmuchbytes, 0));
3567 type = build_varying_struct (string);
3568 loc = build_decl (VAR_DECL,
3569 get_unique_identifier ("WRTEXTCS"),
3571 t = assign_temp (type, 0, 1, 0);
3573 exp = chill_convert_for_assignment (type, item, 0);
3574 expand_assignment (loc, exp, 0, 0);
3575 item_addr = force_addr_of (loc);
3576 the_size = integer_zero_node;
3577 enumname = "__IO_CharVaryingLoc";
3582 item_addr = force_addr_of (item);
3583 the_size = size_in_bytes (item_type);
3584 enumname = "__IO_CharStrLoc";
3588 expand_assignment (string, item_addr, 0, 0);
3589 expand_assignment (length, size_in_bytes (item_type), 0, 0);
3592 else if (CH_BOOLS_TYPE_P (item_type))
3594 /* we have a bitstring */
3595 tree t = build_component_ref (array_ref, get_identifier ("__t"));
3596 tree forxx = build_component_ref (t, get_identifier ("__loccharstring"));
3597 tree string = build_component_ref (forxx, get_identifier ("string"));
3598 tree length = build_component_ref (forxx, get_identifier ("string_length"));
3600 if (do_read && readonly)
3602 error ("argument %d is READonly", idxcnt + 1 + argoffset);
3607 /* in this read case the argument must be referable */
3610 error ("argument %d must be referable", idxcnt + 1 + argoffset);
3614 else if (! referable)
3616 /* in the write case we create a temporary if not referable */
3617 tree loc = build_decl (VAR_DECL,
3618 get_unique_identifier ("WRTEXTVS"),
3620 DECL_RTL (loc) = assign_temp (item_type, 0, 1, 0);
3621 expand_assignment (loc, item, 0, 0);
3622 item_addr = force_addr_of (loc);
3625 expand_assignment (string, item_addr, 0, 0);
3626 expand_assignment (length, build_chill_length (item), 0, 0);
3628 enumname = "__IO_BitStrLoc";
3630 else if (TREE_CODE (item_type) == REAL_TYPE)
3632 /* process a (long_)real */
3633 tree t, forxx, to_assign;
3635 if (do_read && readonly)
3637 error ("argument %d is READonly", idxcnt + 1 + argoffset);
3640 if (do_read && ! referable)
3642 error ("argument %d must be referable", idxcnt + 1 + argoffset);
3646 if (lookup_name (ridpointers[RID_FLOAT]) == TYPE_NAME (item_type))
3648 /* we have a real */
3651 enumname = "__IO_RealLoc";
3652 fieldname = "__locreal";
3653 to_assign = item_addr;
3657 enumname = "__IO_RealVal";
3658 fieldname = "__valreal";
3664 /* we have a long_real */
3667 enumname = "__IO_LongRealLoc";
3668 fieldname = "__loclongreal";
3669 to_assign = item_addr;
3673 enumname = "__IO_LongRealVal";
3674 fieldname = "__vallongreal";
3678 t = build_component_ref (array_ref, get_identifier ("__t"));
3679 forxx = build_component_ref (t, get_identifier (fieldname));
3680 expand_assignment (forxx, to_assign, 0, 0);
3683 /* don't process them for now */
3684 else if (TREE_CODE (item_type) == POINTER_TYPE)
3686 /* we have a pointer */
3689 __t = build_component_ref (array_ref, get_identifier ("__t"));
3690 __forxx = build_component_ref (__t, get_identifier ("__forpointer"));
3691 expand_assignment (__forxx, item, 0, 0);
3692 enumname = "_IO_Pointer";
3694 else if (item_type == instance_type_node)
3696 /* we have an INSTANCE */
3699 __t = build_component_ref (array_ref, get_identifier ("__t"));
3700 __forxx = build_component_ref (__t, get_identifier ("__forinstance"));
3701 expand_assignment (__forxx, item, 0, 0);
3702 enumname = "_IO_Instance";
3707 /* datatype is not yet implemented, issue a warning */
3708 error ("cannot process mode of argument %d for %sTEXT.", idxcnt + 1 + argoffset,
3709 do_read ? "READ" : "WRITE");
3710 enumname = "__IO_UNUSED";
3713 /* do assignment of the enum */
3716 tree descr = build_component_ref (array_ref,
3717 get_identifier ("__descr"));
3718 expand_assignment (descr,
3719 lookup_name (get_identifier (enumname)), 0, 0);
3723 /* set up address and length of iolist */
3724 *iolist_addr = build_chill_addr_expr (iolist, (char *)0);
3725 *iolist_length = build_int_2 (iolen, 0);
3728 /* check the format string */
3742 #define isDEC(c) ( chartab[(c)] & DEC )
3743 #define isCVC(c) ( chartab[(c)] & CVC )
3744 #define isEDC(c) ( chartab[(c)] & EDC )
3745 #define isIOC(c) ( chartab[(c)] & IOC )
3747 #define isXXX(c,XXX) ( chartab[(c)] & XXX )
3750 short int chartab[256] = {
3751 0, 0, 0, 0, 0, 0, 0, 0,
3752 0, SPC, SPC, SPC, SPC, SPC, 0, 0,
3754 0, 0, 0, 0, 0, 0, 0, 0,
3755 0, 0, 0, 0, 0, 0, 0, 0,
3757 SPC, IOC, 0, 0, 0, 0, 0, 0,
3758 SCS, SCS, SCS, SCS+IOC, SCS, SCS+IOC, SCS, SCS+IOC,
3759 BIN+OCT+DEC+HEX, BIN+OCT+DEC+HEX, OCT+DEC+HEX, OCT+DEC+HEX, OCT+DEC+HEX,
3760 OCT+DEC+HEX, OCT+DEC+HEX, OCT+DEC+HEX,
3761 DEC+HEX, DEC+HEX, SCS, SCS, SCS+EDC, SCS+IOC, SCS+EDC, IOC,
3763 0, LET+HEX+BIL, LET+HEX+BIL+CVC, LET+HEX+BIL+CVC, LET+HEX+BIL, LET+HEX,
3765 LET+BIL+CVC, LET, LET, LET, LET, LET, LET, LET+CVC,
3767 LET, LET, LET, LET, LET+EDC, LET, LET, LET,
3768 LET+EDC, LET, LET, SCS, 0, SCS, 0, USC,
3770 0, LET+HEX, LET+HEX, LET+HEX, LET+HEX, LET+HEX, LET+HEX, LET,
3771 LET, LET, LET, LET, LET, LET, LET, LET,
3773 LET, LET, LET, LET, LET, LET, LET, LET,
3774 LET, LET, LET, 0, 0, 0, 0, 0
3779 FormatText, FirstPercent, RepFact, ConvClause, EditClause, ClauseEnd,
3780 AfterWidth, FractWidth, FractWidthCont, ExpoWidth, ExpoWidthCont,
3781 ClauseWidth, CatchPadding, LastPercent
3784 #define CONVERSIONCODES "CHOBF"
3787 DefaultConv, HexConv, OctalConv, BinaryConv, ScientConv
3789 static convcode_t convcode;
3796 static unsigned long fractionwidth;
3798 #define IOCODES "/+-?!="
3800 NextRecord, NextPage, CurrentLine, Prompt, Emit, EndPage
3802 static iocode_t iocode;
3804 #define EDITCODES "X<>T"
3806 SpaceSkip, SkipLeft, SkipRight, Tabulation
3808 static editcode_t editcode;
3810 static unsigned long clausewidth;
3811 static Boolean leftadjust;
3812 static Boolean overflowev;
3813 static Boolean dynamicwid;
3814 static Boolean paddingdef;
3815 static char paddingchar;
3816 static Boolean fractiondef;
3817 static Boolean exponentdef;
3818 static unsigned long exponentwidth;
3819 static unsigned long repetition;
3822 NormalEnd, EndAtParen, TextFailEnd
3825 /* NOTE: varibale have to be set to False before calling check_format_string */
3826 static Boolean empty_printed;
3828 static int formstroffset;
3831 check_exprlist (code, exprlist, argnum, repetition)
3835 unsigned long repetition;
3837 tree expr, type, result;
3839 while (repetition--)
3841 if (exprlist == NULL_TREE)
3843 if (empty_printed == False)
3845 warning ("too few arguments for this format string");
3846 empty_printed = True;
3850 expr = TREE_VALUE (exprlist);
3851 result = exprlist = TREE_CHAIN (exprlist);
3852 if (expr == NULL_TREE || TREE_CODE (expr) == ERROR_MARK)
3854 type = TREE_TYPE (expr);
3855 if (type == NULL_TREE || TREE_CODE (type) == ERROR_MARK)
3857 if (TREE_CODE (type) == REFERENCE_TYPE)
3858 type = TREE_TYPE (type);
3859 if (type == NULL_TREE || TREE_CODE (type) == ERROR_MARK)
3865 /* %C, everything is allowed. Not know types are flaged later. */
3868 /* %F, must be a REAL */
3869 if (TREE_CODE (type) != REAL_TYPE)
3870 warning ("type of argument %d invalid for conversion code at offset %d",
3871 argnum, formstroffset);
3877 /* %H, %O, %B, and V as clause width */
3878 if (TREE_CODE (type) != INTEGER_TYPE)
3879 warning ("type of argument %d invalid for conversion code at offset %d",
3880 argnum, formstroffset);
3883 /* there is an invalid conversion code */
3891 scanformcont (fcs, len, fcsptr, lenptr, exprlist, exprptr,
3892 firstargnum, nextargnum)
3902 fcsstate_t state = FormatText;
3914 state = FirstPercent;
3917 after_first_percent: ;
3928 *exprptr = exprlist;
3929 *nextargnum = firstargnum;
3935 repetition = curr - '0';
3941 test_for_control_codes: ;
3945 convcode = strchr (CONVERSIONCODES, curr) - CONVERSIONCODES;
3951 fractiondef = False;
3952 /* fractionwidth = 0; default depends on mode ! */
3953 exponentdef = False;
3956 /* check the argument */
3957 exprlist = check_exprlist (convcode, exprlist, firstargnum, repetition);
3964 editcode = strchr (EDITCODES, curr) - EDITCODES;
3966 clausewidth = editcode == Tabulation ? 0 : 1;
3972 iocode = strchr (IOCODES, curr) - IOCODES;
3977 unsigned long times = repetition;
3985 if (scanformcont (fcs, len, &cntfcs, &cntlen,
3986 exprlist, &cntexprlist,
3987 firstargnum, &nextarg) != EndAtParen )
3989 warning ("unmatched open paren");
3992 exprlist = cntexprlist;
3998 exprlist = cntexprlist;
3999 firstargnum = nextarg;
4003 warning ("bad format specification character (offset %d)", formstroffset);
4005 /* skip one argument */
4006 if (exprlist != NULL_TREE)
4007 exprlist = TREE_CHAIN (exprlist);
4014 if (repetition > (ULONG_MAX - dig)/10)
4016 warning ("repetition factor overflow (offset %d)", formstroffset);
4019 repetition = repetition*10 + dig;
4022 goto test_for_control_codes;
4027 state = ClauseWidth;
4028 clausewidth = curr - '0';
4034 warning ("duplicate qualifier (offset %d)", formstroffset);
4041 warning ("duplicate qualifier (offset %d)", formstroffset);
4048 warning ("duplicate qualifier (offset %d)", formstroffset);
4050 state = CatchPadding;
4054 test_for_variable_width: ;
4059 exprlist = check_exprlist (-1, exprlist, firstargnum, 1);
4063 goto test_for_fraction_width;
4069 if (clausewidth > (ULONG_MAX - dig)/10)
4070 warning ("clause width overflow (offset %d)", formstroffset);
4072 clausewidth = clausewidth*10 + dig;
4077 test_for_fraction_width: ;
4081 if (convcode != DefaultConv && convcode != ScientConv)
4083 warning ("no fraction (offset %d)", formstroffset);
4091 goto test_for_exponent_width;
4096 state = FractWidthCont;
4097 fractionwidth = curr - '0';
4101 warning ("no fraction width (offset %d)", formstroffset);
4103 case FractWidthCont:
4107 if (fractionwidth > (ULONG_MAX - dig)/10)
4108 warning ("fraction width overflow (offset %d)", formstroffset);
4110 fractionwidth = fractionwidth*10 + dig;
4114 test_for_exponent_width: ;
4117 if (convcode != ScientConv)
4119 warning ("no exponent (offset %d)", formstroffset);
4127 goto test_for_final_percent;
4132 state = ExpoWidthCont;
4133 exponentwidth = curr - '0';
4137 warning ("no exponent width (offset %d)", formstroffset);
4143 if (exponentwidth > (ULONG_MAX - dig)/10)
4144 warning ("exponent width overflow (offset %d)", formstroffset);
4146 exponentwidth = exponentwidth*10 + dig;
4151 test_for_final_percent: ;
4155 state = LastPercent;
4170 state = ClauseWidth;
4171 clausewidth = curr - '0';
4174 goto test_for_variable_width;
4182 goto after_first_percent;
4185 error ("internal error in check_format_string");
4198 warning ("bad format specification character (offset %d)", formstroffset);
4201 warning ("no padding character (offset %d)", formstroffset);
4208 *exprptr = exprlist;
4209 *nextargnum = firstargnum;
4213 check_format_string (format_str, exprlist, firstargnum)
4222 if (TREE_CODE (format_str) != STRING_CST)
4223 /* do nothing if we don't have a string constant */
4227 scanformcont (TREE_STRING_POINTER (format_str),
4228 TREE_STRING_LENGTH (format_str), &x, &y,
4232 /* too may arguments for format string */
4233 warning ("too many arguments for this format string");
4240 if (TREE_CODE (expr) == INDIRECT_REF)
4242 tree x = TREE_OPERAND (expr, 0);
4243 tree y = TREE_OPERAND (x, 0);
4244 return int_size_in_bytes (TREE_TYPE (y));
4246 else if (TREE_CODE (expr) == CONCAT_EXPR)
4247 return intsize_of_charsexpr (expr);
4249 return int_size_in_bytes (TREE_TYPE (expr));
4253 intsize_of_charsexpr (expr)
4256 int op0size, op1size;
4258 if (TREE_CODE (expr) != CONCAT_EXPR)
4261 /* find maximum length of CONCAT_EXPR, this is the worst case */
4262 op0size = get_max_size (TREE_OPERAND (expr, 0));
4263 op1size = get_max_size (TREE_OPERAND (expr, 1));
4264 if (op0size == -1 || op1size == -1)
4266 return op0size + op1size;
4270 build_chill_writetext (text_arg, exprlist)
4271 tree text_arg, exprlist;
4273 tree iolist_addr = null_pointer_node;
4274 tree iolist_length = integer_zero_node;
4281 tree filename, linenumber;
4282 tree format_str = NULL_TREE, indexexpr = NULL_TREE;
4283 rtx iolist_rtx = NULL_RTX;
4286 /* make some checks */
4287 if (text_arg == NULL_TREE || TREE_CODE (text_arg) == ERROR_MARK)
4288 return error_mark_node;
4290 if (exprlist != NULL_TREE)
4292 if (TREE_CODE (exprlist) != TREE_LIST)
4293 return error_mark_node;
4296 /* check the text argument */
4297 if (chill_varying_string_type_p (TREE_TYPE (text_arg)))
4299 /* build outstr-addr and outstr-length assuming that this is a CHAR (n) VARYING */
4300 outstr_addr = force_addr_of (text_arg);
4301 outstr_length = size_in_bytes (CH_VARYING_ARRAY_TYPE (TREE_TYPE (text_arg)));
4302 outfunction = lookup_name (get_identifier ("__writetext_s"));
4303 format_str = TREE_VALUE (exprlist);
4304 exprlist = TREE_CHAIN (exprlist);
4306 else if (CH_IS_TEXT_MODE (TREE_TYPE (text_arg)))
4308 /* we have a text mode */
4311 if (! check_text (text_arg, 1, "WRITETEXT"))
4312 return error_mark_node;
4313 indexmode = text_indexmode (TREE_TYPE (text_arg));
4314 if (indexmode == void_type_node)
4317 format_str = TREE_VALUE (exprlist);
4318 exprlist = TREE_CHAIN (exprlist);
4322 /* we have an index. there must be an index argument before format string */
4323 indexexpr = TREE_VALUE (exprlist);
4324 exprlist = TREE_CHAIN (exprlist);
4325 if (! CH_COMPATIBLE (indexexpr, indexmode))
4327 if (chill_varying_string_type_p (TREE_TYPE (indexexpr)) ||
4328 (CH_CHARS_TYPE_P (TREE_TYPE (indexexpr)) ||
4329 (flag_old_strings && TREE_CODE (indexexpr) == INTEGER_CST &&
4330 TREE_CODE (TREE_TYPE (indexexpr)) == CHAR_TYPE)))
4331 error ("missing index expression");
4333 error ("incompatible index mode");
4334 return error_mark_node;
4336 if (exprlist == NULL_TREE)
4338 error ("Too few arguments in call to `writetext'");
4339 return error_mark_node;
4341 format_str = TREE_VALUE (exprlist);
4342 exprlist = TREE_CHAIN (exprlist);
4345 outstr_addr = force_addr_of (text_arg);
4346 outstr_length = convert (integer_type_node, indexexpr);
4347 outfunction = lookup_name (get_identifier ("__writetext_f"));
4351 error ("argument 1 for WRITETEXT must be a TEXT or CHARS(n) VARYING location");
4352 return error_mark_node;
4355 /* check the format string */
4356 fstrtype = TREE_TYPE (format_str);
4357 if (CH_CHARS_TYPE_P (fstrtype) ||
4358 (flag_old_strings && TREE_CODE (format_str) == INTEGER_CST &&
4359 TREE_CODE (fstrtype) == CHAR_TYPE))
4361 /* we have a character string */
4362 fstr_addr = force_addr_of (format_str);
4363 fstr_length = size_in_bytes (fstrtype);
4365 else if (chill_varying_string_type_p (TREE_TYPE (format_str)))
4367 /* we have a varying char string */
4369 = force_addr_of (build_component_ref (format_str, var_data_id));
4370 fstr_length = build_component_ref (format_str, var_length_id);
4374 error ("`format string' for WRITETEXT must be a CHARACTER string");
4375 return error_mark_node;
4378 empty_printed = False;
4379 check_format_string (format_str, exprlist, argoffset + 3);
4380 process_io_list (exprlist, &iolist_addr, &iolist_length, &iolist_rtx, 0, argoffset);
4382 /* tree to call the function */
4384 filename = force_addr_of (get_chill_filename ());
4385 linenumber = get_chill_linenumber ();
4388 build_chill_function_call (outfunction,
4389 tree_cons (NULL_TREE, outstr_addr,
4390 tree_cons (NULL_TREE, outstr_length,
4391 tree_cons (NULL_TREE, fstr_addr,
4392 tree_cons (NULL_TREE, fstr_length,
4393 tree_cons (NULL_TREE, iolist_addr,
4394 tree_cons (NULL_TREE, iolist_length,
4395 tree_cons (NULL_TREE, filename,
4396 tree_cons (NULL_TREE, linenumber,
4397 NULL_TREE))))))))));
4399 /* get rid of the iolist variable, if we have one */
4400 if (iolist_rtx != NULL_RTX)
4408 /* return something the rest of the machinery can work with,
4410 return build1 (CONVERT_EXPR, void_type_node, integer_zero_node);
4414 build_chill_readtext (text_arg, exprlist)
4415 tree text_arg, exprlist;
4417 tree instr_addr, instr_length, infunction;
4418 tree fstr_addr, fstr_length, fstrtype;
4419 tree iolist_addr = null_pointer_node;
4420 tree iolist_length = integer_zero_node;
4421 tree filename, linenumber;
4422 tree format_str = NULL_TREE, indexexpr = NULL_TREE;
4423 rtx iolist_rtx = NULL_RTX;
4426 /* make some checks */
4427 if (text_arg == NULL_TREE || TREE_CODE (text_arg) == ERROR_MARK)
4428 return error_mark_node;
4430 if (exprlist != NULL_TREE)
4432 if (TREE_CODE (exprlist) != TREE_LIST)
4433 return error_mark_node;
4436 /* check the text argument */
4437 if (CH_CHARS_TYPE_P (TREE_TYPE (text_arg)))
4439 instr_addr = force_addr_of (text_arg);
4440 instr_length = size_in_bytes (TREE_TYPE (text_arg));
4441 infunction = lookup_name (get_identifier ("__readtext_s"));
4442 format_str = TREE_VALUE (exprlist);
4443 exprlist = TREE_CHAIN (exprlist);
4445 else if (chill_varying_string_type_p (TREE_TYPE (text_arg)))
4448 = force_addr_of (build_component_ref (text_arg, var_data_id));
4449 instr_length = build_component_ref (text_arg, var_length_id);
4450 infunction = lookup_name (get_identifier ("__readtext_s"));
4451 format_str = TREE_VALUE (exprlist);
4452 exprlist = TREE_CHAIN (exprlist);
4454 else if (CH_IS_TEXT_MODE (TREE_TYPE (text_arg)))
4456 /* we have a text mode */
4459 if (! check_text (text_arg, 1, "READTEXT"))
4460 return error_mark_node;
4461 indexmode = text_indexmode (TREE_TYPE (text_arg));
4462 if (indexmode == void_type_node)
4465 format_str = TREE_VALUE (exprlist);
4466 exprlist = TREE_CHAIN (exprlist);
4470 /* we have an index. there must be an index argument before format string */
4471 indexexpr = TREE_VALUE (exprlist);
4472 exprlist = TREE_CHAIN (exprlist);
4473 if (! CH_COMPATIBLE (indexexpr, indexmode))
4475 if (chill_varying_string_type_p (TREE_TYPE (indexexpr)) ||
4476 (CH_CHARS_TYPE_P (TREE_TYPE (indexexpr)) ||
4477 (flag_old_strings && TREE_CODE (indexexpr) == INTEGER_CST &&
4478 TREE_CODE (TREE_TYPE (indexexpr)) == CHAR_TYPE)))
4479 error ("missing index expression");
4481 error ("incompatible index mode");
4482 return error_mark_node;
4484 if (exprlist == NULL_TREE)
4486 error ("Too few arguments in call to `readtext'");
4487 return error_mark_node;
4489 format_str = TREE_VALUE (exprlist);
4490 exprlist = TREE_CHAIN (exprlist);
4493 instr_addr = force_addr_of (text_arg);
4494 instr_length = convert (integer_type_node, indexexpr);
4495 infunction = lookup_name (get_identifier ("__readtext_f"));
4499 error ("argument 1 for READTEXT must be a TEXT location or CHARS(n) [ VARYING ] expression");
4500 return error_mark_node;
4503 /* check the format string */
4504 fstrtype = TREE_TYPE (format_str);
4505 if (CH_CHARS_TYPE_P (fstrtype))
4507 /* we have a character string */
4508 fstr_addr = force_addr_of (format_str);
4509 fstr_length = size_in_bytes (fstrtype);
4511 else if (chill_varying_string_type_p (fstrtype))
4513 /* we have a CHARS(n) VARYING */
4515 = force_addr_of (build_component_ref (format_str, var_data_id));
4516 fstr_length = build_component_ref (format_str, var_length_id);
4520 error ("`format string' for READTEXT must be a CHARACTER string");
4521 return error_mark_node;
4524 empty_printed = False;
4525 check_format_string (format_str, exprlist, argoffset + 3);
4526 process_io_list (exprlist, &iolist_addr, &iolist_length, &iolist_rtx, 1, argoffset);
4528 /* build the function call */
4529 filename = force_addr_of (get_chill_filename ());
4530 linenumber = get_chill_linenumber ();
4532 build_chill_function_call (infunction,
4533 tree_cons (NULL_TREE, instr_addr,
4534 tree_cons (NULL_TREE, instr_length,
4535 tree_cons (NULL_TREE, fstr_addr,
4536 tree_cons (NULL_TREE, fstr_length,
4537 tree_cons (NULL_TREE, iolist_addr,
4538 tree_cons (NULL_TREE, iolist_length,
4539 tree_cons (NULL_TREE, filename,
4540 tree_cons (NULL_TREE, linenumber,
4541 NULL_TREE))))))))));
4543 /* get rid of the iolist variable, if we have one */
4544 if (iolist_rtx != NULL_RTX)
4552 /* return something the rest of the machinery can work with,
4554 return build1 (CONVERT_EXPR, void_type_node, integer_zero_node);
4557 /* this function build all neccesary enum-tables used for
4558 WRITETEXT or READTEXT of an enum */
4560 void build_enum_tables ()
4562 SAVE_ENUM_NAMES *names;
4565 /* We temporarily reset the maximum_field_alignment to zero so the
4566 compiler's init data structures can be compatible with the
4567 run-time system, even when we're compiling with -fpack. */
4568 extern int maximum_field_alignment;
4569 int save_maximum_field_alignment;
4574 save_maximum_field_alignment = maximum_field_alignment;
4575 maximum_field_alignment = 0;
4577 /* output all names */
4578 names = used_enum_names;
4580 while (names != (SAVE_ENUM_NAMES *)0)
4582 tree var = get_unique_identifier ("ENUMNAME");
4585 type = build_string_type (char_type_node,
4586 build_int_2 (IDENTIFIER_LENGTH (names->name) + 1, 0));
4587 names->decl = decl_temp1 (var, type, 1,
4588 build_chill_string (IDENTIFIER_LENGTH (names->name) + 1,
4589 IDENTIFIER_POINTER (names->name)),
4591 names = names->forward;
4594 /* output the tables and pointers to tables */
4596 while (wrk != (SAVE_ENUMS *)0)
4598 tree varptr = wrk->ptrdecl;
4599 tree table_addr = null_pointer_node;
4600 tree init = NULL_TREE, one_entry;
4601 tree table, idxlist, tabletype, addr;
4602 SAVE_ENUM_VALUES *vals;
4606 for (i = 0; i < wrk->num_vals; i++)
4608 tree decl = vals->name->decl;
4609 addr = build1 (ADDR_EXPR,
4610 build_pointer_type (char_type_node),
4612 TREE_CONSTANT (addr) = 1;
4613 one_entry = tree_cons (NULL_TREE, build_int_2 (vals->val, 0),
4614 tree_cons (NULL_TREE, addr, NULL_TREE));
4615 one_entry = build_nt (CONSTRUCTOR, NULL_TREE, one_entry);
4616 init = tree_cons (NULL_TREE, one_entry, init);
4620 /* add the terminator (name = null_pointer_node) to constructor */
4621 one_entry = tree_cons (NULL_TREE, integer_zero_node,
4622 tree_cons (NULL_TREE, null_pointer_node, NULL_TREE));
4623 one_entry = build_nt (CONSTRUCTOR, NULL_TREE, one_entry);
4624 init = tree_cons (NULL_TREE, one_entry, init);
4625 init = nreverse (init);
4626 init = build_nt (CONSTRUCTOR, NULL_TREE, init);
4627 TREE_CONSTANT (init) = 1;
4629 /* generate table */
4630 idxlist = build_tree_list (NULL_TREE,
4631 build_chill_range_type (NULL_TREE,
4633 build_int_2 (wrk->num_vals, 0)));
4634 tabletype = build_chill_array_type (TREE_TYPE (enum_table_type),
4635 idxlist, 0, NULL_TREE);
4636 table = decl_temp1 (get_unique_identifier ("ENUMTAB"), tabletype,
4638 table_addr = build1 (ADDR_EXPR,
4639 build_pointer_type (TREE_TYPE (enum_table_type)),
4641 TREE_CONSTANT (table_addr) = 1;
4643 /* generate pointer to table */
4644 decl_temp1 (DECL_NAME (varptr), TREE_TYPE (table_addr),
4645 1, table_addr, 0, 0);
4647 /* free that stuff */
4648 saveptr = wrk->forward;
4657 /* free all the names */
4658 names = used_enum_names;
4659 while (names != (SAVE_ENUM_NAMES *)0)
4661 saveptr = names->forward;
4666 used_enums = (SAVE_ENUMS *)0;
4667 used_enum_names = (SAVE_ENUM_NAMES *)0;
4668 maximum_field_alignment = save_maximum_field_alignment;