1 /* Implement I/O-related actions for CHILL.
2 Copyright (C) 1992, 93, 94, 98, 99, 2000 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
PARAMS ((tree
));
39 static tree add_enum_to_list
PARAMS ((tree
, tree
));
40 static void build_chill_io_list_type
PARAMS ((void));
41 static void build_io_types
PARAMS ((void));
42 static void declare_predefined_file
PARAMS ((const char *, const char *));
43 static tree build_access_part
PARAMS ((void));
44 static tree textlocation_mode
PARAMS ((tree
));
45 static int check_assoc
PARAMS ((tree
, int, const char *));
46 static tree assoc_call
PARAMS ((tree
, tree
, const char *));
47 static int check_transfer
PARAMS ((tree
, int, const char *));
48 static int connect_process_optionals
PARAMS ((tree
, tree
*, tree
*, tree
));
49 static tree connect_text
PARAMS ((tree
, tree
, tree
, tree
));
50 static tree connect_access
PARAMS ((tree
, tree
, tree
, tree
));
51 static int check_access
PARAMS ((tree
, int, const char *));
52 static int check_text
PARAMS ((tree
, int, const char *));
53 static tree get_final_type_and_range
PARAMS ((tree
, tree
*, tree
*));
54 static void process_io_list
PARAMS ((tree
, tree
*, tree
*, rtx
*,
56 static void check_format_string
PARAMS ((tree
, tree
, int));
57 static int get_max_size
PARAMS ((tree
));
59 /* association mode */
60 tree association_type_node
;
61 /* initialzier for association mode */
62 tree association_init_value
;
64 /* NOTE: should be same as in runtime/chillrt0.c */
65 #define STDIO_TEXT_LENGTH 1024
66 /* mode of stdout, stdin, stderr*/
67 static tree stdio_type_node
;
69 /* usage- and where modes */
73 /* we have to distinguish between io-list-type for WRITETEXT
74 and for READTEXT. WRITETEXT does not process ranges and
75 READTEXT must get pointers to the variables.
77 /* variable to hold the type of the io_list */
78 static tree chill_io_list_type
= NULL_TREE
;
80 /* the type for the enum tables */
81 static tree enum_table_type
= NULL_TREE
;
83 /* structure to save enums for later use in compilation */
84 typedef struct save_enum_names
86 struct save_enum_names
*forward
;
91 static SAVE_ENUM_NAMES
*used_enum_names
= (SAVE_ENUM_NAMES
*)0;
93 typedef struct save_enum_values
96 struct save_enum_names
*name
;
99 typedef struct save_enums
101 struct save_enums
*forward
;
106 struct save_enum_values
*vals
;
109 static SAVE_ENUMS
*used_enums
= (SAVE_ENUMS
*)0;
112 /* Function collects all enums are necessary to collect, makes a copy of
113 the value and returns a VAR_DECL external to current function describing
114 the pointer to a name table, which will be generated at the end of
118 static tree
add_enum_to_list (type
, context
)
123 SAVE_ENUMS
*wrk
= used_enums
;
124 SAVE_ENUM_VALUES
*vals
;
125 SAVE_ENUM_NAMES
*names
;
127 while (wrk
!= (SAVE_ENUMS
*)0)
129 /* search for this enum already in use */
130 if (wrk
->context
== context
&& wrk
->type
== type
)
132 /* yes, found. look if the ptrdecl is valid in this scope */
133 char *name
= IDENTIFIER_POINTER (DECL_NAME (wrk
->ptrdecl
));
134 tree var
= get_identifier (name
);
135 tree decl
= lookup_name (var
);
137 if (decl
== NULL_TREE
)
139 /* no, not valid in this context, declare it */
140 decl
= decl_temp1 (var
, build_pointer_type (TREE_TYPE (enum_table_type
)),
150 /* not yet found -- generate an entry */
151 wrk
= (SAVE_ENUMS
*)xmalloc (sizeof (SAVE_ENUMS
));
152 wrk
->forward
= used_enums
;
155 /* generate the pointer decl */
156 wrk
->ptrdecl
= get_unique_identifier ("ENUMTABPTR");
157 wrk
->ptrdecl
= decl_temp1 (wrk
->ptrdecl
, build_pointer_type (TREE_TYPE (enum_table_type
)),
160 /* save information for later use */
161 wrk
->context
= context
;
164 /* insert the names and values */
165 tmp
= TYPE_FIELDS (type
);
166 wrk
->num_vals
= list_length (tmp
);
167 vals
= (SAVE_ENUM_VALUES
*)xmalloc (sizeof (SAVE_ENUM_VALUES
) * wrk
->num_vals
);
170 while (tmp
!= NULL_TREE
)
172 /* search if name is already in use */
173 names
= used_enum_names
;
174 while (names
!= (SAVE_ENUM_NAMES
*)0)
176 if (names
->name
== TREE_PURPOSE (tmp
))
178 names
= names
->forward
;
180 if (names
== (SAVE_ENUM_NAMES
*)0)
182 /* we have to insert one */
183 names
= (SAVE_ENUM_NAMES
*)xmalloc (sizeof (SAVE_ENUM_NAMES
));
184 names
->forward
= used_enum_names
;
185 used_enum_names
= names
;
186 names
->decl
= NULL_TREE
;
187 names
->name
= TREE_PURPOSE (tmp
);
190 vals
->val
= TREE_INT_CST_LOW (TREE_VALUE (tmp
));
192 /* next entry in enum */
194 tmp
= TREE_CHAIN (tmp
);
197 /* return the generated decl */
203 build_chill_io_list_type ()
205 tree list
= NULL_TREE
;
206 tree result
, enum1
, listbase
;
209 tree forcharstring
, forset_W
, forset_R
, forboolrange
;
211 tree forintrange
, intunion
, forsetrange
, forcharrange
;
212 tree long_type
, ulong_type
, union_type
;
214 long_type
= long_integer_type_node
;
215 ulong_type
= long_unsigned_type_node
;
217 if (chill_io_list_type
!= NULL_TREE
)
221 /* first build the enum for the desriptor */
222 enum1
= start_enum (NULL_TREE
);
223 result
= build_enumerator (get_identifier ("__IO_UNUSED"),
225 list
= chainon (result
, list
);
227 result
= build_enumerator (get_identifier ("__IO_ByteVal"),
229 list
= chainon (result
, list
);
231 result
= build_enumerator (get_identifier ("__IO_UByteVal"),
233 list
= chainon (result
, list
);
235 result
= build_enumerator (get_identifier ("__IO_IntVal"),
237 list
= chainon (result
, list
);
239 result
= build_enumerator (get_identifier ("__IO_UIntVal"),
241 list
= chainon (result
, list
);
243 result
= build_enumerator (get_identifier ("__IO_LongVal"),
245 list
= chainon (result
, list
);
247 result
= build_enumerator (get_identifier ("__IO_ULongVal"),
249 list
= chainon (result
, list
);
251 result
= build_enumerator (get_identifier ("__IO_ByteLoc"),
253 list
= chainon (result
, list
);
255 result
= build_enumerator (get_identifier ("__IO_UByteLoc"),
257 list
= chainon (result
, list
);
259 result
= build_enumerator (get_identifier ("__IO_IntLoc"),
261 list
= chainon (result
, list
);
263 result
= build_enumerator (get_identifier ("__IO_UIntLoc"),
265 list
= chainon (result
, list
);
267 result
= build_enumerator (get_identifier ("__IO_LongLoc"),
269 list
= chainon (result
, list
);
271 result
= build_enumerator (get_identifier ("__IO_ULongLoc"),
273 list
= chainon (result
, list
);
275 result
= build_enumerator (get_identifier ("__IO_ByteRangeLoc"),
277 list
= chainon (result
, list
);
279 result
= build_enumerator (get_identifier ("__IO_UByteRangeLoc"),
281 list
= chainon (result
, list
);
283 result
= build_enumerator (get_identifier ("__IO_IntRangeLoc"),
285 list
= chainon (result
, list
);
287 result
= build_enumerator (get_identifier ("__IO_UIntRangeLoc"),
289 list
= chainon (result
, list
);
291 result
= build_enumerator (get_identifier ("__IO_LongRangeLoc"),
293 list
= chainon (result
, list
);
295 result
= build_enumerator (get_identifier ("__IO_ULongRangeLoc"),
297 list
= chainon (result
, list
);
299 result
= build_enumerator (get_identifier ("__IO_BoolVal"),
301 list
= chainon (result
, list
);
303 result
= build_enumerator (get_identifier ("__IO_BoolLoc"),
305 list
= chainon (result
, list
);
307 result
= build_enumerator (get_identifier ("__IO_BoolRangeLoc"),
309 list
= chainon (result
, list
);
311 result
= build_enumerator (get_identifier ("__IO_SetVal"),
313 list
= chainon (result
, list
);
315 result
= build_enumerator (get_identifier ("__IO_SetLoc"),
317 list
= chainon (result
, list
);
319 result
= build_enumerator (get_identifier ("__IO_SetRangeLoc"),
321 list
= chainon (result
, list
);
323 result
= build_enumerator (get_identifier ("__IO_CharVal"),
325 list
= chainon (result
, list
);
327 result
= build_enumerator (get_identifier ("__IO_CharLoc"),
329 list
= chainon (result
, list
);
331 result
= build_enumerator (get_identifier ("__IO_CharRangeLoc"),
333 list
= chainon (result
, list
);
335 result
= build_enumerator (get_identifier ("__IO_CharStrLoc"),
337 list
= chainon (result
, list
);
339 result
= build_enumerator (get_identifier ("__IO_CharVaryingLoc"),
341 list
= chainon (result
, list
);
343 result
= build_enumerator (get_identifier ("__IO_BitStrLoc"),
345 list
= chainon (result
, list
);
347 result
= build_enumerator (get_identifier ("__IO_RealVal"),
349 list
= chainon (result
, list
);
351 result
= build_enumerator (get_identifier ("__IO_RealLoc"),
353 list
= chainon (result
, list
);
355 result
= build_enumerator (get_identifier ("__IO_LongRealVal"),
357 list
= chainon (result
, list
);
359 result
= build_enumerator (get_identifier ("__IO_LongRealLoc"),
361 list
= chainon (result
, list
);
363 result
= build_enumerator (get_identifier ("_IO_Pointer"),
365 list
= chainon (result
, list
);
368 result
= finish_enum (enum1
, list
);
369 pushdecl (io_descriptor
= build_decl (TYPE_DECL
,
370 get_identifier ("__tmp_IO_enum"),
372 /* prevent seizing/granting of the decl */
373 DECL_SOURCE_LINE (io_descriptor
) = 0;
374 satisfy_decl (io_descriptor
, 0);
376 /* build type for enum_tables */
377 decl1
= build_decl (FIELD_DECL
, get_identifier ("value"),
379 DECL_INITIAL (decl1
) = NULL_TREE
;
380 decl2
= build_decl (FIELD_DECL
, get_identifier ("name"),
381 build_pointer_type (char_type_node
));
382 DECL_INITIAL (decl2
) = NULL_TREE
;
383 TREE_CHAIN (decl1
) = decl2
;
384 TREE_CHAIN (decl2
) = NULL_TREE
;
385 result
= build_chill_struct_type (decl1
);
386 pushdecl (enum_table_type
= build_decl (TYPE_DECL
,
387 get_identifier ("__tmp_IO_enum_table_type"),
389 DECL_SOURCE_LINE (enum_table_type
) = 0;
390 satisfy_decl (enum_table_type
, 0);
392 /* build type for writing a set mode */
393 decl1
= build_decl (FIELD_DECL
, get_identifier ("value"),
395 DECL_INITIAL (decl1
) = NULL_TREE
;
398 decl2
= build_decl (FIELD_DECL
, get_identifier ("name_table"),
399 build_pointer_type (TREE_TYPE (enum_table_type
)));
400 DECL_INITIAL (decl2
) = NULL_TREE
;
401 TREE_CHAIN (decl1
) = decl2
;
403 TREE_CHAIN (decl2
) = NULL_TREE
;
405 result
= build_chill_struct_type (listbase
);
406 pushdecl (forset_W
= build_decl (TYPE_DECL
,
407 get_identifier ("__tmp_WIO_set"),
409 DECL_SOURCE_LINE (forset_W
) = 0;
410 satisfy_decl (forset_W
, 0);
412 /* build type for charrange */
413 decl1
= build_decl (FIELD_DECL
, get_identifier ("ptr"),
414 build_pointer_type (char_type_node
));
415 DECL_INITIAL (decl1
) = NULL_TREE
;
418 decl2
= build_decl (FIELD_DECL
, get_identifier ("lower"),
420 DECL_INITIAL (decl2
) = NULL_TREE
;
421 TREE_CHAIN (decl1
) = decl2
;
424 decl2
= build_decl (FIELD_DECL
, get_identifier ("upper"),
426 DECL_INITIAL (decl2
) = NULL_TREE
;
427 TREE_CHAIN (decl1
) = decl2
;
428 TREE_CHAIN (decl2
) = NULL_TREE
;
430 result
= build_chill_struct_type (listbase
);
431 pushdecl (forcharrange
= build_decl (TYPE_DECL
,
432 get_identifier ("__tmp_IO_charrange"),
434 DECL_SOURCE_LINE (forcharrange
) = 0;
435 satisfy_decl (forcharrange
, 0);
437 /* type for integer range */
438 decl1
= build_tree_list (NULL_TREE
,
439 build_decl (FIELD_DECL
,
440 get_identifier ("_slong"),
444 decl2
= build_tree_list (NULL_TREE
,
445 build_decl (FIELD_DECL
,
446 get_identifier ("_ulong"),
448 TREE_CHAIN (decl1
) = decl2
;
449 TREE_CHAIN (decl2
) = NULL_TREE
;
451 decl1
= grok_chill_variantdefs (NULL_TREE
, listbase
, NULL_TREE
);
452 TREE_CHAIN (decl1
) = NULL_TREE
;
453 result
= build_chill_struct_type (decl1
);
454 pushdecl (intunion
= build_decl (TYPE_DECL
,
455 get_identifier ("__tmp_IO_long"),
457 DECL_SOURCE_LINE (intunion
) = 0;
458 satisfy_decl (intunion
, 0);
460 decl1
= build_decl (FIELD_DECL
,
461 get_identifier ("ptr"),
465 decl2
= build_decl (FIELD_DECL
,
466 get_identifier ("lower"),
467 TREE_TYPE (intunion
));
468 TREE_CHAIN (decl1
) = decl2
;
471 decl2
= build_decl (FIELD_DECL
,
472 get_identifier ("upper"),
473 TREE_TYPE (intunion
));
474 TREE_CHAIN (decl1
) = decl2
;
475 TREE_CHAIN (decl2
) = NULL_TREE
;
477 result
= build_chill_struct_type (listbase
);
478 pushdecl (forintrange
= build_decl (TYPE_DECL
,
479 get_identifier ("__tmp_IO_intrange"),
481 DECL_SOURCE_LINE (forintrange
) = 0;
482 satisfy_decl (forintrange
, 0);
484 /* build structure for bool range */
485 decl1
= build_decl (FIELD_DECL
,
486 get_identifier ("ptr"),
488 DECL_INITIAL (decl1
) = NULL_TREE
;
491 decl2
= build_decl (FIELD_DECL
,
492 get_identifier ("lower"),
494 DECL_INITIAL (decl2
) = NULL_TREE
;
495 TREE_CHAIN (decl1
) = decl2
;
498 decl2
= build_decl (FIELD_DECL
,
499 get_identifier ("upper"),
501 DECL_INITIAL (decl2
) = NULL_TREE
;
502 TREE_CHAIN (decl1
) = decl2
;
503 TREE_CHAIN (decl2
) = NULL_TREE
;
505 result
= build_chill_struct_type (listbase
);
506 pushdecl (forboolrange
= build_decl (TYPE_DECL
,
507 get_identifier ("__tmp_RIO_boolrange"),
509 DECL_SOURCE_LINE (forboolrange
) = 0;
510 satisfy_decl (forboolrange
, 0);
512 /* build type for reading a set */
513 decl1
= build_decl (FIELD_DECL
, get_identifier ("ptr"),
515 DECL_INITIAL (decl1
) = NULL_TREE
;
518 decl2
= build_decl (FIELD_DECL
, get_identifier ("length"),
520 DECL_INITIAL (decl2
) = NULL_TREE
;
521 TREE_CHAIN (decl1
) = decl2
;
524 decl2
= build_decl (FIELD_DECL
, get_identifier ("name_table"),
525 build_pointer_type (TREE_TYPE (enum_table_type
)));
526 DECL_INITIAL (decl2
) = NULL_TREE
;
527 TREE_CHAIN (decl1
) = decl2
;
528 TREE_CHAIN (decl2
) = NULL_TREE
;
530 result
= build_chill_struct_type (listbase
);
531 pushdecl (forset_R
= build_decl (TYPE_DECL
,
532 get_identifier ("__tmp_RIO_set"),
534 DECL_SOURCE_LINE (forset_R
) = 0;
535 satisfy_decl (forset_R
, 0);
537 /* build type for setrange */
538 decl1
= build_decl (FIELD_DECL
, get_identifier ("ptr"),
540 DECL_INITIAL (decl1
) = NULL_TREE
;
543 decl2
= build_decl (FIELD_DECL
, get_identifier ("length"),
545 DECL_INITIAL (decl2
) = NULL_TREE
;
546 TREE_CHAIN (decl1
) = decl2
;
549 decl2
= build_decl (FIELD_DECL
, get_identifier ("name_table"),
550 build_pointer_type (TREE_TYPE (enum_table_type
)));
551 DECL_INITIAL (decl2
) = NULL_TREE
;
552 TREE_CHAIN (decl1
) = decl2
;
555 decl2
= build_decl (FIELD_DECL
, get_identifier ("lower"),
557 DECL_INITIAL (decl2
) = NULL_TREE
;
558 TREE_CHAIN (decl1
) = decl2
;
561 decl2
= build_decl (FIELD_DECL
, get_identifier ("upper"),
563 DECL_INITIAL (decl2
) = NULL_TREE
;
564 TREE_CHAIN (decl1
) = decl2
;
565 TREE_CHAIN (decl2
) = NULL_TREE
;
567 result
= build_chill_struct_type (listbase
);
568 pushdecl (forsetrange
= build_decl (TYPE_DECL
,
569 get_identifier ("__tmp_RIO_setrange"),
571 DECL_SOURCE_LINE (forsetrange
) = 0;
572 satisfy_decl (forsetrange
, 0);
574 /* build structure for character string */
575 decl1
= build_decl (FIELD_DECL
,
576 get_identifier ("string"),
577 build_pointer_type (char_type_node
));
578 DECL_INITIAL (decl1
) = NULL_TREE
;
581 decl2
= build_decl (FIELD_DECL
,
582 get_identifier ("string_length"),
584 DECL_INITIAL (decl2
) = NULL_TREE
;
585 TREE_CHAIN (decl1
) = decl2
;
587 TREE_CHAIN (decl2
) = NULL_TREE
;
589 result
= build_chill_struct_type (listbase
);
590 pushdecl (forcharstring
= build_decl (TYPE_DECL
,
591 get_identifier ("__tmp_IO_forcharstring"), result
));
592 DECL_SOURCE_LINE (forcharstring
) = 0;
593 satisfy_decl (forcharstring
, 0);
595 /* build the union */
596 decl1
= build_tree_list (NULL_TREE
,
597 build_decl (FIELD_DECL
,
598 get_identifier ("__valbyte"),
599 signed_char_type_node
));
602 decl2
= build_tree_list (NULL_TREE
,
603 build_decl (FIELD_DECL
,
604 get_identifier ("__valubyte"),
605 unsigned_char_type_node
));
606 TREE_CHAIN (decl1
) = decl2
;
609 decl2
= build_tree_list (NULL_TREE
,
610 build_decl (FIELD_DECL
,
611 get_identifier ("__valint"),
612 chill_integer_type_node
));
613 TREE_CHAIN (decl1
) = decl2
;
616 decl2
= build_tree_list (NULL_TREE
,
617 build_decl (FIELD_DECL
,
618 get_identifier ("__valuint"),
619 chill_unsigned_type_node
));
620 TREE_CHAIN (decl1
) = decl2
;
623 decl2
= build_tree_list (NULL_TREE
,
624 build_decl (FIELD_DECL
,
625 get_identifier ("__vallong"),
627 TREE_CHAIN (decl1
) = decl2
;
630 decl2
= build_tree_list (NULL_TREE
,
631 build_decl (FIELD_DECL
,
632 get_identifier ("__valulong"),
634 TREE_CHAIN (decl1
) = decl2
;
637 decl2
= build_tree_list (NULL_TREE
,
638 build_decl (FIELD_DECL
,
639 get_identifier ("__locint"),
641 TREE_CHAIN (decl1
) = decl2
;
644 decl2
= build_tree_list (NULL_TREE
,
645 build_decl (FIELD_DECL
,
646 get_identifier ("__locintrange"),
647 TREE_TYPE (forintrange
)));
648 TREE_CHAIN (decl1
) = decl2
;
651 decl2
= build_tree_list (NULL_TREE
,
652 build_decl (FIELD_DECL
,
653 get_identifier ("__valbool"),
655 TREE_CHAIN (decl1
) = decl2
;
658 decl2
= build_tree_list (NULL_TREE
,
659 build_decl (FIELD_DECL
,
660 get_identifier ("__locbool"),
661 build_pointer_type (boolean_type_node
)));
662 TREE_CHAIN (decl1
) = decl2
;
665 decl2
= build_tree_list (NULL_TREE
,
666 build_decl (FIELD_DECL
,
667 get_identifier ("__locboolrange"),
668 TREE_TYPE (forboolrange
)));
669 TREE_CHAIN (decl1
) = decl2
;
672 decl2
= build_tree_list (NULL_TREE
,
673 build_decl (FIELD_DECL
,
674 get_identifier ("__valset"),
675 TREE_TYPE (forset_W
)));
676 TREE_CHAIN (decl1
) = decl2
;
679 decl2
= build_tree_list (NULL_TREE
,
680 build_decl (FIELD_DECL
,
681 get_identifier ("__locset"),
682 TREE_TYPE (forset_R
)));
683 TREE_CHAIN (decl1
) = decl2
;
686 decl2
= build_tree_list (NULL_TREE
,
687 build_decl (FIELD_DECL
,
688 get_identifier ("__locsetrange"),
689 TREE_TYPE (forsetrange
)));
690 TREE_CHAIN (decl1
) = decl2
;
693 decl2
= build_tree_list (NULL_TREE
,
694 build_decl (FIELD_DECL
,
695 get_identifier ("__valchar"),
697 TREE_CHAIN (decl1
) = decl2
;
700 decl2
= build_tree_list (NULL_TREE
,
701 build_decl (FIELD_DECL
,
702 get_identifier ("__locchar"),
703 build_pointer_type (char_type_node
)));
704 TREE_CHAIN (decl1
) = decl2
;
707 decl2
= build_tree_list (NULL_TREE
,
708 build_decl (FIELD_DECL
,
709 get_identifier ("__loccharrange"),
710 TREE_TYPE (forcharrange
)));
711 TREE_CHAIN (decl1
) = decl2
;
714 decl2
= build_tree_list (NULL_TREE
,
715 build_decl (FIELD_DECL
,
716 get_identifier ("__loccharstring"),
717 TREE_TYPE (forcharstring
)));
718 TREE_CHAIN (decl1
) = decl2
;
721 decl2
= build_tree_list (NULL_TREE
,
722 build_decl (FIELD_DECL
,
723 get_identifier ("__valreal"),
725 TREE_CHAIN (decl1
) = decl2
;
728 decl2
= build_tree_list (NULL_TREE
,
729 build_decl (FIELD_DECL
,
730 get_identifier ("__locreal"),
731 build_pointer_type (float_type_node
)));
732 TREE_CHAIN (decl1
) = decl2
;
735 decl2
= build_tree_list (NULL_TREE
,
736 build_decl (FIELD_DECL
,
737 get_identifier ("__vallongreal"),
739 TREE_CHAIN (decl1
) = decl2
;
742 decl2
= build_tree_list (NULL_TREE
,
743 build_decl (FIELD_DECL
,
744 get_identifier ("__loclongreal"),
745 build_pointer_type (double_type_node
)));
746 TREE_CHAIN (decl1
) = decl2
;
750 decl2
= build_tree_list (NULL_TREE
,
751 build_decl (FIELD_DECL
,
752 get_identifier ("__forpointer"),
754 TREE_CHAIN (decl1
) = decl2
;
758 TREE_CHAIN (decl2
) = NULL_TREE
;
760 decl1
= grok_chill_variantdefs (NULL_TREE
, listbase
, NULL_TREE
);
761 TREE_CHAIN (decl1
) = NULL_TREE
;
762 result
= build_chill_struct_type (decl1
);
763 pushdecl (union_type
= build_decl (TYPE_DECL
,
764 get_identifier ("__tmp_WIO_union"),
766 DECL_SOURCE_LINE (union_type
) = 0;
767 satisfy_decl (union_type
, 0);
769 /* now build the final structure */
770 decl1
= build_decl (FIELD_DECL
, get_identifier ("__t"),
771 TREE_TYPE (union_type
));
772 DECL_INITIAL (decl1
) = NULL_TREE
;
775 decl2
= build_decl (FIELD_DECL
, get_identifier ("__descr"),
778 TREE_CHAIN (decl1
) = decl2
;
779 TREE_CHAIN (decl2
) = NULL_TREE
;
781 result
= build_chill_struct_type (listbase
);
782 pushdecl (chill_io_list_type
= build_decl (TYPE_DECL
,
783 get_identifier ("__tmp_IO_list"),
785 DECL_SOURCE_LINE (chill_io_list_type
) = 0;
786 satisfy_decl (chill_io_list_type
, 0);
789 /* build the ASSOCIATION, ACCESS and TEXT mode types */
793 tree listbase
, decl1
, decl2
, result
, association
;
797 /* the association mode */
798 listbase
= build_decl (FIELD_DECL
,
799 get_identifier ("flags"),
800 long_unsigned_type_node
);
801 DECL_INITIAL (listbase
) = NULL_TREE
;
804 decl2
= build_decl (FIELD_DECL
,
805 get_identifier ("pathname"),
807 DECL_INITIAL (decl2
) = NULL_TREE
;
808 TREE_CHAIN (decl1
) = decl2
;
811 decl2
= build_decl (FIELD_DECL
,
812 get_identifier ("access"),
814 DECL_INITIAL (decl2
) = NULL_TREE
;
815 TREE_CHAIN (decl1
) = decl2
;
818 decl2
= build_decl (FIELD_DECL
,
819 get_identifier ("handle"),
821 DECL_INITIAL (decl2
) = NULL_TREE
;
822 TREE_CHAIN (decl1
) = decl2
;
825 decl2
= build_decl (FIELD_DECL
,
826 get_identifier ("bufptr"),
828 DECL_INITIAL (decl2
) = NULL_TREE
;
829 TREE_CHAIN (decl1
) = decl2
;
832 decl2
= build_decl (FIELD_DECL
,
833 get_identifier ("syserrno"),
834 long_integer_type_node
);
835 DECL_INITIAL (decl2
) = NULL_TREE
;
836 TREE_CHAIN (decl1
) = decl2
;
839 decl2
= build_decl (FIELD_DECL
,
840 get_identifier ("usage"),
842 DECL_INITIAL (decl2
) = NULL_TREE
;
843 TREE_CHAIN (decl1
) = decl2
;
846 decl2
= build_decl (FIELD_DECL
,
847 get_identifier ("ctl_pre"),
849 DECL_INITIAL (decl2
) = NULL_TREE
;
850 TREE_CHAIN (decl1
) = decl2
;
853 decl2
= build_decl (FIELD_DECL
,
854 get_identifier ("ctl_post"),
856 DECL_INITIAL (decl2
) = NULL_TREE
;
857 TREE_CHAIN (decl1
) = decl2
;
858 TREE_CHAIN (decl2
) = NULL_TREE
;
860 result
= build_chill_struct_type (listbase
);
861 pushdecl (association
= build_decl (TYPE_DECL
,
862 ridpointers
[(int)RID_ASSOCIATION
],
864 DECL_SOURCE_LINE (association
) = 0;
865 satisfy_decl (association
, 0);
866 association_type_node
= TREE_TYPE (association
);
867 TYPE_NAME (association_type_node
) = association
;
868 CH_NOVELTY (association_type_node
) = association
;
869 CH_TYPE_NONVALUE_P(association_type_node
) = 1;
870 CH_TYPE_NONVALUE_P(association
) = 1;
872 /* initialiser for association type */
873 tmp
= convert (char_type_node
, integer_zero_node
);
874 association_init_value
=
875 build_nt (CONSTRUCTOR
, NULL_TREE
,
876 tree_cons (NULL_TREE
, integer_zero_node
, /* flags */
877 tree_cons (NULL_TREE
, null_pointer_node
, /* pathname */
878 tree_cons (NULL_TREE
, null_pointer_node
, /* access */
879 tree_cons (NULL_TREE
, integer_minus_one_node
, /* handle */
880 tree_cons (NULL_TREE
, null_pointer_node
, /* bufptr */
881 tree_cons (NULL_TREE
, integer_zero_node
, /* syserrno */
882 tree_cons (NULL_TREE
, tmp
, /* usage */
883 tree_cons (NULL_TREE
, tmp
, /* ctl_pre */
884 tree_cons (NULL_TREE
, tmp
, /* ctl_post */
887 /* the type for stdin, stdout, stderr */
889 decl1
= build_decl (FIELD_DECL
,
890 get_identifier ("flags"),
891 long_unsigned_type_node
);
892 DECL_INITIAL (decl1
) = NULL_TREE
;
895 decl2
= build_decl (FIELD_DECL
,
896 get_identifier ("text_record"),
898 DECL_INITIAL (decl2
) = NULL_TREE
;
899 TREE_CHAIN (decl1
) = decl2
;
902 decl2
= build_decl (FIELD_DECL
,
903 get_identifier ("access_sub"),
905 DECL_INITIAL (decl2
) = NULL_TREE
;
906 TREE_CHAIN (decl1
) = decl2
;
909 decl2
= build_decl (FIELD_DECL
,
910 get_identifier ("actual_index"),
911 long_unsigned_type_node
);
912 DECL_INITIAL (decl2
) = NULL_TREE
;
913 TREE_CHAIN (decl1
) = decl2
;
914 TREE_CHAIN (decl2
) = NULL_TREE
;
915 txt
= build_chill_struct_type (listbase
);
918 decl1
= build_decl (FIELD_DECL
,
919 get_identifier ("flags"),
920 long_unsigned_type_node
);
921 DECL_INITIAL (decl1
) = NULL_TREE
;
924 decl2
= build_decl (FIELD_DECL
,
925 get_identifier ("reclength"),
926 long_unsigned_type_node
);
927 DECL_INITIAL (decl2
) = NULL_TREE
;
928 TREE_CHAIN (decl1
) = decl2
;
931 decl2
= build_decl (FIELD_DECL
,
932 get_identifier ("lowindex"),
933 long_integer_type_node
);
934 DECL_INITIAL (decl2
) = NULL_TREE
;
935 TREE_CHAIN (decl1
) = decl2
;
938 decl2
= build_decl (FIELD_DECL
,
939 get_identifier ("highindex"),
940 long_integer_type_node
);
941 DECL_INITIAL (decl2
) = NULL_TREE
;
942 TREE_CHAIN (decl1
) = decl2
;
945 decl2
= build_decl (FIELD_DECL
,
946 get_identifier ("association"),
948 DECL_INITIAL (decl2
) = NULL_TREE
;
949 TREE_CHAIN (decl1
) = decl2
;
952 decl2
= build_decl (FIELD_DECL
,
953 get_identifier ("base"),
954 long_unsigned_type_node
);
955 DECL_INITIAL (decl2
) = NULL_TREE
;
956 TREE_CHAIN (decl1
) = decl2
;
959 decl2
= build_decl (FIELD_DECL
,
960 get_identifier ("storelocptr"),
962 DECL_INITIAL (decl2
) = NULL_TREE
;
963 TREE_CHAIN (decl1
) = decl2
;
966 decl2
= build_decl (FIELD_DECL
,
967 get_identifier ("rectype"),
968 long_integer_type_node
);
969 DECL_INITIAL (decl2
) = NULL_TREE
;
970 TREE_CHAIN (decl1
) = decl2
;
971 TREE_CHAIN (decl2
) = NULL_TREE
;
972 acc
= build_chill_struct_type (listbase
);
975 tmp
= build_string_type (char_type_node
, build_int_2 (STDIO_TEXT_LENGTH
, 0));
976 tloc
= build_varying_struct (tmp
);
978 /* now the final mode */
979 decl1
= build_decl (FIELD_DECL
, get_identifier ("txt"), txt
);
982 decl2
= build_decl (FIELD_DECL
, get_identifier ("acc"), acc
);
983 TREE_CHAIN (decl1
) = decl2
;
986 decl2
= build_decl (FIELD_DECL
, get_identifier ("tloc"), tloc
);
987 TREE_CHAIN (decl1
) = decl2
;
990 decl2
= build_lang_decl (TYPE_DECL
, get_identifier ("__indexmode"),
992 TREE_CHAIN (decl1
) = decl2
;
995 decl2
= build_decl (CONST_DECL
, get_identifier ("__textlength"),
997 DECL_INITIAL (decl2
) = build_int_2 (STDIO_TEXT_LENGTH
, 0);
998 TREE_CHAIN (decl1
) = decl2
;
1001 decl2
= build_decl (CONST_DECL
, get_identifier ("__dynamic"),
1003 DECL_INITIAL (decl2
) = integer_zero_node
;
1004 TREE_CHAIN (decl1
) = decl2
;
1005 TREE_CHAIN (decl2
) = NULL_TREE
;
1007 result
= build_chill_struct_type (listbase
);
1008 pushdecl (tmp
= build_decl (TYPE_DECL
,
1009 get_identifier ("__stdio_text"),
1011 DECL_SOURCE_LINE (tmp
) = 0;
1012 satisfy_decl (tmp
, 0);
1013 stdio_type_node
= TREE_TYPE (tmp
);
1014 CH_IS_TEXT_MODE (stdio_type_node
) = 1;
1016 /* predefined usage mode */
1017 enum1
= start_enum (NULL_TREE
);
1018 listbase
= NULL_TREE
;
1019 result
= build_enumerator (
1020 get_identifier ((ignore_case
|| ! special_UC
) ? "readonly" : "READONLY"),
1022 listbase
= chainon (result
, listbase
);
1023 result
= build_enumerator (
1024 get_identifier ((ignore_case
|| ! special_UC
) ? "writeonly" : "WRITEONLY"),
1026 listbase
= chainon (result
, listbase
);
1027 result
= build_enumerator (
1028 get_identifier ((ignore_case
|| ! special_UC
) ? "readwrite" : "READWRITE"),
1030 listbase
= chainon (result
, listbase
);
1031 result
= finish_enum (enum1
, listbase
);
1032 pushdecl (tmp
= build_decl (TYPE_DECL
,
1033 get_identifier ((ignore_case
|| ! special_UC
) ? "usage" : "USAGE"),
1035 DECL_SOURCE_LINE (tmp
) = 0;
1036 satisfy_decl (tmp
, 0);
1037 usage_type_node
= TREE_TYPE (tmp
);
1038 TYPE_NAME (usage_type_node
) = tmp
;
1039 CH_NOVELTY (usage_type_node
) = tmp
;
1041 /* predefined where mode */
1042 enum1
= start_enum (NULL_TREE
);
1043 listbase
= NULL_TREE
;
1044 result
= build_enumerator (
1045 get_identifier ((ignore_case
|| ! special_UC
) ? "first" : "FIRST"),
1047 listbase
= chainon (result
, listbase
);
1048 result
= build_enumerator (
1049 get_identifier ((ignore_case
|| ! special_UC
) ? "same" : "SAME"),
1051 listbase
= chainon (result
, listbase
);
1052 result
= build_enumerator (
1053 get_identifier ((ignore_case
|| ! special_UC
) ? "last" : "LAST"),
1055 listbase
= chainon (result
, listbase
);
1056 result
= finish_enum (enum1
, listbase
);
1057 pushdecl (tmp
= build_decl (TYPE_DECL
,
1058 get_identifier ((ignore_case
|| ! special_UC
) ? "where" : "WHERE"),
1060 DECL_SOURCE_LINE (tmp
) = 0;
1061 satisfy_decl (tmp
, 0);
1062 where_type_node
= TREE_TYPE (tmp
);
1063 TYPE_NAME (where_type_node
) = tmp
;
1064 CH_NOVELTY (where_type_node
) = tmp
;
1068 declare_predefined_file (name
, assembler_name
)
1070 const char *assembler_name
;
1072 tree decl
= build_lang_decl (VAR_DECL
, get_identifier (name
),
1074 DECL_ASSEMBLER_NAME (decl
) = get_identifier(assembler_name
);
1075 TREE_STATIC (decl
) = 1;
1076 TREE_PUBLIC (decl
) = 1;
1077 DECL_EXTERNAL (decl
) = 1;
1078 DECL_IN_SYSTEM_HEADER (decl
) = 1;
1079 make_decl_rtl (decl
, 0, 1);
1084 /* initialisation of all IO/related functions, types, etc. */
1088 /* We temporarily reset the maximum_field_alignment to zero so the
1089 compiler's init data structures can be compatible with the
1090 run-time system, even when we're compiling with -fpack. */
1091 unsigned int save_maximum_field_alignment
= maximum_field_alignment
;
1093 extern tree chill_predefined_function_type
;
1094 tree endlink
= void_list_node
;
1095 tree bool_ftype_ptr_ptr_int
;
1096 tree ptr_ftype_ptr_ptr_int
;
1097 tree luns_ftype_ptr_ptr_int
;
1098 tree int_ftype_ptr_ptr_int
;
1099 tree ptr_ftype_ptr_ptr_int_ptr_int_ptr_int
;
1100 tree void_ftype_ptr_ptr_int_ptr_int_ptr_int
;
1101 tree void_ftype_ptr_ptr_int
;
1102 tree void_ftype_ptr_ptr_int_int_int_long_ptr_int
;
1103 tree ptr_ftype_ptr_int_ptr_ptr_int
;
1104 tree void_ftype_ptr_int_ptr_luns_ptr_int
;
1105 tree void_ftype_ptr_ptr_ptr_int
;
1106 tree void_ftype_ptr_int_ptr_int
;
1107 tree void_ftype_ptr_int_ptr_int_ptr_int_ptr_int
;
1109 maximum_field_alignment
= 0;
1111 builtin_function ((ignore_case
|| ! special_UC
) ? "associate" : "ASSOCIATE",
1112 chill_predefined_function_type
,
1113 BUILT_IN_ASSOCIATE
, BUILT_IN_NORMAL
, NULL_PTR
);
1114 builtin_function ((ignore_case
|| ! special_UC
) ? "connect" : "CONNECT",
1115 chill_predefined_function_type
,
1116 BUILT_IN_CONNECT
, BUILT_IN_NORMAL
, NULL_PTR
);
1117 builtin_function ((ignore_case
|| ! special_UC
) ? "create" : "CREATE",
1118 chill_predefined_function_type
,
1119 BUILT_IN_CREATE
, BUILT_IN_NORMAL
, NULL_PTR
);
1120 builtin_function ((ignore_case
|| ! special_UC
) ? "delete" : "DELETE",
1121 chill_predefined_function_type
,
1122 BUILT_IN_CH_DELETE
, BUILT_IN_NORMAL
, NULL_PTR
);
1123 builtin_function ((ignore_case
|| ! special_UC
) ? "disconnect" : "DISCONNECT",
1124 chill_predefined_function_type
,
1125 BUILT_IN_DISCONNECT
, BUILT_IN_NORMAL
, NULL_PTR
);
1126 builtin_function ((ignore_case
|| ! special_UC
) ? "dissociate" : "DISSOCIATE",
1127 chill_predefined_function_type
,
1128 BUILT_IN_DISSOCIATE
, BUILT_IN_NORMAL
, NULL_PTR
);
1129 builtin_function ((ignore_case
|| ! special_UC
) ? "eoln" : "EOLN",
1130 chill_predefined_function_type
,
1131 BUILT_IN_EOLN
, BUILT_IN_NORMAL
, NULL_PTR
);
1132 builtin_function ((ignore_case
|| ! special_UC
) ? "existing" : "EXISTING",
1133 chill_predefined_function_type
,
1134 BUILT_IN_EXISTING
, BUILT_IN_NORMAL
, NULL_PTR
);
1135 builtin_function ((ignore_case
|| ! special_UC
) ? "getassociation" : "GETASSOCIATION",
1136 chill_predefined_function_type
,
1137 BUILT_IN_GETASSOCIATION
, BUILT_IN_NORMAL
, NULL_PTR
);
1138 builtin_function ((ignore_case
|| ! special_UC
) ? "gettextaccess" : "GETTEXTASSCESS",
1139 chill_predefined_function_type
,
1140 BUILT_IN_GETTEXTACCESS
, BUILT_IN_NORMAL
, NULL_PTR
);
1141 builtin_function ((ignore_case
|| ! special_UC
) ? "gettextindex" : "GETTEXTINDEX",
1142 chill_predefined_function_type
,
1143 BUILT_IN_GETTEXTINDEX
, BUILT_IN_NORMAL
, NULL_PTR
);
1144 builtin_function ((ignore_case
|| ! special_UC
) ? "gettextrecord" : "GETTEXTRECORD",
1145 chill_predefined_function_type
,
1146 BUILT_IN_GETTEXTRECORD
, BUILT_IN_NORMAL
, NULL_PTR
);
1147 builtin_function ((ignore_case
|| ! special_UC
) ? "getusage" : "GETUSAGE",
1148 chill_predefined_function_type
,
1149 BUILT_IN_GETUSAGE
, BUILT_IN_NORMAL
, NULL_PTR
);
1150 builtin_function ((ignore_case
|| ! special_UC
) ? "indexable" : "INDEXABLE",
1151 chill_predefined_function_type
,
1152 BUILT_IN_INDEXABLE
, BUILT_IN_NORMAL
, NULL_PTR
);
1153 builtin_function ((ignore_case
|| ! special_UC
) ? "isassociated" : "ISASSOCIATED",
1154 chill_predefined_function_type
,
1155 BUILT_IN_ISASSOCIATED
, BUILT_IN_NORMAL
, NULL_PTR
);
1156 builtin_function ((ignore_case
|| ! special_UC
) ? "modify" : "MODIFY",
1157 chill_predefined_function_type
,
1158 BUILT_IN_MODIFY
, BUILT_IN_NORMAL
, NULL_PTR
);
1159 builtin_function ((ignore_case
|| ! special_UC
) ? "outoffile" : "OUTOFFILE",
1160 chill_predefined_function_type
,
1161 BUILT_IN_OUTOFFILE
, BUILT_IN_NORMAL
, NULL_PTR
);
1162 builtin_function ((ignore_case
|| ! special_UC
) ? "readable" : "READABLE",
1163 chill_predefined_function_type
,
1164 BUILT_IN_READABLE
, BUILT_IN_NORMAL
, NULL_PTR
);
1165 builtin_function ((ignore_case
|| ! special_UC
) ? "readrecord" : "READRECORD",
1166 chill_predefined_function_type
,
1167 BUILT_IN_READRECORD
, BUILT_IN_NORMAL
, NULL_PTR
);
1168 builtin_function ((ignore_case
|| ! special_UC
) ? "readtext" : "READTEXT",
1169 chill_predefined_function_type
,
1170 BUILT_IN_READTEXT
, BUILT_IN_NORMAL
, NULL_PTR
);
1171 builtin_function ((ignore_case
|| ! special_UC
) ? "sequencible" : "SEQUENCIBLE",
1172 chill_predefined_function_type
,
1173 BUILT_IN_SEQUENCIBLE
, BUILT_IN_NORMAL
, NULL_PTR
);
1174 builtin_function ((ignore_case
|| ! special_UC
) ? "settextaccess" : "SETTEXTACCESS",
1175 chill_predefined_function_type
,
1176 BUILT_IN_SETTEXTACCESS
, BUILT_IN_NORMAL
, NULL_PTR
);
1177 builtin_function ((ignore_case
|| ! special_UC
) ? "settextindex" : "SETTEXTINDEX",
1178 chill_predefined_function_type
,
1179 BUILT_IN_SETTEXTINDEX
, BUILT_IN_NORMAL
, NULL_PTR
);
1180 builtin_function ((ignore_case
|| ! special_UC
) ? "settextrecord" : "SETTEXTRECORD",
1181 chill_predefined_function_type
,
1182 BUILT_IN_SETTEXTRECORD
, BUILT_IN_NORMAL
, NULL_PTR
);
1183 builtin_function ((ignore_case
|| ! special_UC
) ? "variable" : "VARIABLE",
1184 chill_predefined_function_type
,
1185 BUILT_IN_VARIABLE
, BUILT_IN_NORMAL
, NULL_PTR
);
1186 builtin_function ((ignore_case
|| ! special_UC
) ? "writeable" : "WRITEABLE",
1187 chill_predefined_function_type
,
1188 BUILT_IN_WRITEABLE
, BUILT_IN_NORMAL
, NULL_PTR
);
1189 builtin_function ((ignore_case
|| ! special_UC
) ? "writerecord" : "WRITERECORD",
1190 chill_predefined_function_type
,
1191 BUILT_IN_WRITERECORD
, BUILT_IN_NORMAL
, NULL_PTR
);
1192 builtin_function ((ignore_case
|| ! special_UC
) ? "writetext" : "WRITETEXT",
1193 chill_predefined_function_type
,
1194 BUILT_IN_WRITETEXT
, BUILT_IN_NORMAL
, NULL_PTR
);
1196 /* build function prototypes */
1197 bool_ftype_ptr_ptr_int
=
1198 build_function_type (boolean_type_node
,
1199 tree_cons (NULL_TREE
, ptr_type_node
,
1200 tree_cons (NULL_TREE
, ptr_type_node
,
1201 tree_cons (NULL_TREE
, integer_type_node
,
1203 ptr_ftype_ptr_ptr_int_ptr_int_ptr_int
=
1204 build_function_type (ptr_type_node
,
1205 tree_cons (NULL_TREE
, ptr_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
,
1210 tree_cons (NULL_TREE
, ptr_type_node
,
1211 tree_cons (NULL_TREE
, integer_type_node
,
1213 void_ftype_ptr_ptr_int
=
1214 build_function_type (void_type_node
,
1215 tree_cons (NULL_TREE
, ptr_type_node
,
1216 tree_cons (NULL_TREE
, ptr_type_node
,
1217 tree_cons (NULL_TREE
, integer_type_node
,
1219 void_ftype_ptr_ptr_int_ptr_int_ptr_int
=
1220 build_function_type (void_type_node
,
1221 tree_cons (NULL_TREE
, ptr_type_node
,
1222 tree_cons (NULL_TREE
, ptr_type_node
,
1223 tree_cons (NULL_TREE
, integer_type_node
,
1224 tree_cons (NULL_TREE
, ptr_type_node
,
1225 tree_cons (NULL_TREE
, integer_type_node
,
1226 tree_cons (NULL_TREE
, ptr_type_node
,
1227 tree_cons (NULL_TREE
, integer_type_node
,
1229 void_ftype_ptr_ptr_int_int_int_long_ptr_int
=
1230 build_function_type (void_type_node
,
1231 tree_cons (NULL_TREE
, ptr_type_node
,
1232 tree_cons (NULL_TREE
, ptr_type_node
,
1233 tree_cons (NULL_TREE
, integer_type_node
,
1234 tree_cons (NULL_TREE
, integer_type_node
,
1235 tree_cons (NULL_TREE
, integer_type_node
,
1236 tree_cons (NULL_TREE
, long_integer_type_node
,
1237 tree_cons (NULL_TREE
, ptr_type_node
,
1238 tree_cons (NULL_TREE
, integer_type_node
,
1240 ptr_ftype_ptr_ptr_int
=
1241 build_function_type (ptr_type_node
,
1242 tree_cons (NULL_TREE
, ptr_type_node
,
1243 tree_cons (NULL_TREE
, ptr_type_node
,
1244 tree_cons (NULL_TREE
, integer_type_node
,
1246 int_ftype_ptr_ptr_int
=
1247 build_function_type (integer_type_node
,
1248 tree_cons (NULL_TREE
, ptr_type_node
,
1249 tree_cons (NULL_TREE
, ptr_type_node
,
1250 tree_cons (NULL_TREE
, integer_type_node
,
1252 ptr_ftype_ptr_int_ptr_ptr_int
=
1253 build_function_type (ptr_type_node
,
1254 tree_cons (NULL_TREE
, ptr_type_node
,
1255 tree_cons (NULL_TREE
, integer_type_node
,
1256 tree_cons (NULL_TREE
, ptr_type_node
,
1257 tree_cons (NULL_TREE
, ptr_type_node
,
1258 tree_cons (NULL_TREE
, integer_type_node
,
1260 void_ftype_ptr_int_ptr_luns_ptr_int
=
1261 build_function_type (void_type_node
,
1262 tree_cons (NULL_TREE
, ptr_type_node
,
1263 tree_cons (NULL_TREE
, integer_type_node
,
1264 tree_cons (NULL_TREE
, ptr_type_node
,
1265 tree_cons (NULL_TREE
, long_unsigned_type_node
,
1266 tree_cons (NULL_TREE
, ptr_type_node
,
1267 tree_cons (NULL_TREE
, integer_type_node
,
1269 luns_ftype_ptr_ptr_int
=
1270 build_function_type (long_unsigned_type_node
,
1271 tree_cons (NULL_TREE
, ptr_type_node
,
1272 tree_cons (NULL_TREE
, ptr_type_node
,
1273 tree_cons (NULL_TREE
, integer_type_node
,
1275 void_ftype_ptr_ptr_ptr_int
=
1276 build_function_type (void_type_node
,
1277 tree_cons (NULL_TREE
, ptr_type_node
,
1278 tree_cons (NULL_TREE
, ptr_type_node
,
1279 tree_cons (NULL_TREE
, ptr_type_node
,
1280 tree_cons (NULL_TREE
, integer_type_node
,
1282 void_ftype_ptr_int_ptr_int
=
1283 build_function_type (void_type_node
,
1284 tree_cons (NULL_TREE
, ptr_type_node
,
1285 tree_cons (NULL_TREE
, integer_type_node
,
1286 tree_cons (NULL_TREE
, ptr_type_node
,
1287 tree_cons (NULL_TREE
, integer_type_node
,
1289 void_ftype_ptr_int_ptr_int_ptr_int_ptr_int
=
1290 build_function_type (void_type_node
,
1291 tree_cons (NULL_TREE
, ptr_type_node
,
1292 tree_cons (NULL_TREE
, integer_type_node
,
1293 tree_cons (NULL_TREE
, ptr_type_node
,
1294 tree_cons (NULL_TREE
, integer_type_node
,
1295 tree_cons (NULL_TREE
, ptr_type_node
,
1296 tree_cons (NULL_TREE
, integer_type_node
,
1297 tree_cons (NULL_TREE
, ptr_type_node
,
1298 tree_cons (NULL_TREE
, integer_type_node
,
1301 builtin_function ("__associate", ptr_ftype_ptr_ptr_int_ptr_int_ptr_int
,
1302 0, NOT_BUILT_IN
, NULL_PTR
);
1303 builtin_function ("__connect", void_ftype_ptr_ptr_int_int_int_long_ptr_int
,
1304 0, NOT_BUILT_IN
, NULL_PTR
);
1305 builtin_function ("__create", void_ftype_ptr_ptr_int
,
1306 0, NOT_BUILT_IN
, NULL_PTR
);
1307 builtin_function ("__delete", void_ftype_ptr_ptr_int
,
1308 0, NOT_BUILT_IN
, NULL_PTR
);
1309 builtin_function ("__disconnect", void_ftype_ptr_ptr_int
,
1310 0, NOT_BUILT_IN
, NULL_PTR
);
1311 builtin_function ("__dissociate", void_ftype_ptr_ptr_int
,
1312 0, NOT_BUILT_IN
, NULL_PTR
);
1313 builtin_function ("__eoln", bool_ftype_ptr_ptr_int
,
1314 0, NOT_BUILT_IN
, NULL_PTR
);
1315 builtin_function ("__existing", bool_ftype_ptr_ptr_int
,
1316 0, NOT_BUILT_IN
, NULL_PTR
);
1317 builtin_function ("__getassociation", ptr_ftype_ptr_ptr_int
,
1318 0, NOT_BUILT_IN
, NULL_PTR
);
1319 builtin_function ("__gettextaccess", ptr_ftype_ptr_ptr_int
,
1320 0, NOT_BUILT_IN
, NULL_PTR
);
1321 builtin_function ("__gettextindex", luns_ftype_ptr_ptr_int
,
1322 0, NOT_BUILT_IN
, NULL_PTR
);
1323 builtin_function ("__gettextrecord", ptr_ftype_ptr_ptr_int
,
1324 0, NOT_BUILT_IN
, NULL_PTR
);
1325 builtin_function ("__getusage", int_ftype_ptr_ptr_int
,
1326 0, NOT_BUILT_IN
, NULL_PTR
);
1327 builtin_function ("__indexable", bool_ftype_ptr_ptr_int
,
1328 0, NOT_BUILT_IN
, NULL_PTR
);
1329 builtin_function ("__isassociated", bool_ftype_ptr_ptr_int
,
1330 0, NOT_BUILT_IN
, NULL_PTR
);
1331 builtin_function ("__modify", void_ftype_ptr_ptr_int_ptr_int_ptr_int
,
1332 0, NOT_BUILT_IN
, NULL_PTR
);
1333 builtin_function ("__outoffile", bool_ftype_ptr_ptr_int
,
1334 0, NOT_BUILT_IN
, NULL_PTR
);
1335 builtin_function ("__readable", bool_ftype_ptr_ptr_int
,
1336 0, NOT_BUILT_IN
, NULL_PTR
);
1337 builtin_function ("__readrecord", ptr_ftype_ptr_int_ptr_ptr_int
,
1338 0, NOT_BUILT_IN
, NULL_PTR
);
1339 builtin_function ("__readtext_f", void_ftype_ptr_int_ptr_int_ptr_int_ptr_int
,
1340 0, NOT_BUILT_IN
, NULL_PTR
);
1341 builtin_function ("__readtext_s", void_ftype_ptr_int_ptr_int_ptr_int_ptr_int
,
1342 0, NOT_BUILT_IN
, NULL_PTR
);
1343 builtin_function ("__sequencible", bool_ftype_ptr_ptr_int
,
1344 0, NOT_BUILT_IN
, NULL_PTR
);
1345 builtin_function ("__settextaccess", void_ftype_ptr_ptr_ptr_int
,
1346 0, NOT_BUILT_IN
, NULL_PTR
);
1347 builtin_function ("__settextindex", void_ftype_ptr_int_ptr_int
,
1348 0, NOT_BUILT_IN
, NULL_PTR
);
1349 builtin_function ("__settextrecord", void_ftype_ptr_ptr_ptr_int
,
1350 0, NOT_BUILT_IN
, NULL_PTR
);
1351 builtin_function ("__variable", bool_ftype_ptr_ptr_int
,
1352 0, NOT_BUILT_IN
, NULL_PTR
);
1353 builtin_function ("__writeable", bool_ftype_ptr_ptr_int
,
1354 0, NOT_BUILT_IN
, NULL_PTR
);
1355 builtin_function ("__writerecord", void_ftype_ptr_int_ptr_luns_ptr_int
,
1356 0, NOT_BUILT_IN
, NULL_PTR
);
1357 builtin_function ("__writetext_f", void_ftype_ptr_int_ptr_int_ptr_int_ptr_int
,
1358 0, NOT_BUILT_IN
, NULL_PTR
);
1359 builtin_function ("__writetext_s", void_ftype_ptr_int_ptr_int_ptr_int_ptr_int
,
1360 0, NOT_BUILT_IN
, NULL_PTR
);
1362 /* declare ASSOCIATION, ACCESS, and TEXT modes */
1365 /* declare the predefined text locations */
1366 declare_predefined_file ((ignore_case
|| ! special_UC
) ? "stdin" : "STDIN",
1368 declare_predefined_file ((ignore_case
|| ! special_UC
) ? "stdout" : "STDOUT",
1370 declare_predefined_file ((ignore_case
|| ! special_UC
) ? "stderr" : "STDERR",
1373 /* last, but not least, build the chill IO-list type */
1374 build_chill_io_list_type ();
1376 maximum_field_alignment
= save_maximum_field_alignment
;
1379 /* function returns the recordmode of an ACCESS */
1381 access_recordmode (access
)
1386 if (access
== NULL_TREE
|| TREE_CODE (access
) == ERROR_MARK
)
1388 if (! CH_IS_ACCESS_MODE (access
))
1391 field
= TYPE_FIELDS (access
);
1392 for ( ; field
!= NULL_TREE
; field
= TREE_CHAIN (field
))
1394 if (TREE_CODE (field
) == TYPE_DECL
&&
1395 DECL_NAME (field
) == get_identifier ("__recordmode"))
1396 return TREE_TYPE (field
);
1398 return void_type_node
;
1401 /* function invalidates the recordmode of an ACCESS */
1403 invalidate_access_recordmode (access
)
1408 if (access
== NULL_TREE
|| TREE_CODE (access
) == ERROR_MARK
)
1410 if (! CH_IS_ACCESS_MODE (access
))
1413 field
= TYPE_FIELDS (access
);
1414 for ( ; field
!= NULL_TREE
; field
= TREE_CHAIN (field
))
1416 if (TREE_CODE (field
) == TYPE_DECL
&&
1417 DECL_NAME (field
) == get_identifier ("__recordmode"))
1419 TREE_TYPE (field
) = error_mark_node
;
1425 /* function returns the index mode of an ACCESS if there is one,
1426 otherwise NULL_TREE */
1428 access_indexmode (access
)
1433 if (access
== NULL_TREE
|| TREE_CODE (access
) == ERROR_MARK
)
1435 if (! CH_IS_ACCESS_MODE (access
))
1438 field
= TYPE_FIELDS (access
);
1439 for ( ; field
!= NULL_TREE
; field
= TREE_CHAIN (field
))
1441 if (TREE_CODE (field
) == TYPE_DECL
&&
1442 DECL_NAME (field
) == get_identifier ("__indexmode"))
1443 return TREE_TYPE (field
);
1445 return void_type_node
;
1448 /* function returns one if an ACCESS was specified DYNAMIC, otherwise zero */
1450 access_dynamic (access
)
1455 if (access
== NULL_TREE
|| TREE_CODE (access
) == ERROR_MARK
)
1457 if (! CH_IS_ACCESS_MODE (access
))
1460 field
= TYPE_FIELDS (access
);
1461 for ( ; field
!= NULL_TREE
; field
= TREE_CHAIN (field
))
1463 if (TREE_CODE (field
) == CONST_DECL
)
1464 return DECL_INITIAL (field
);
1466 return integer_zero_node
;
1470 returns a structure like
1471 STRUCT (data
STRUCT (flags ULONG
,
1479 this is followed by a
1480 TYPE_DECL __recordmode recordmode
? recordmode
: void_type_node
1481 TYPE_DECL __indexmode indexmode
? indexmode
: void_type_node
1482 CONST_DECL __dynamic dynamic
? integer_one_node
: integer_zero_node
1486 build_access_part ()
1488 tree listbase
, decl
;
1490 listbase
= build_decl (FIELD_DECL
, get_identifier ("flags"),
1491 long_unsigned_type_node
);
1492 decl
= build_decl (FIELD_DECL
, get_identifier ("reclength"),
1493 long_unsigned_type_node
);
1494 listbase
= chainon (listbase
, decl
);
1495 decl
= build_decl (FIELD_DECL
, get_identifier ("lowindex"),
1496 long_unsigned_type_node
);
1497 listbase
= chainon (listbase
, decl
);
1498 decl
= build_decl (FIELD_DECL
, get_identifier ("highindex"),
1499 long_integer_type_node
);
1500 listbase
= chainon (listbase
, decl
);
1501 decl
= build_decl (FIELD_DECL
, get_identifier ("association"),
1503 listbase
= chainon (listbase
, decl
);
1504 decl
= build_decl (FIELD_DECL
, get_identifier ("base"),
1505 long_unsigned_type_node
);
1506 listbase
= chainon (listbase
, decl
);
1507 decl
= build_decl (FIELD_DECL
, get_identifier ("storelocptr"),
1509 listbase
= chainon (listbase
, decl
);
1510 decl
= build_decl (FIELD_DECL
, get_identifier ("rectype"),
1511 long_integer_type_node
);
1512 listbase
= chainon (listbase
, decl
);
1513 return build_chill_struct_type (listbase
);
1517 build_access_mode (indexmode
, recordmode
, dynamic
)
1522 tree type
, listbase
, decl
, datamode
;
1524 if (indexmode
!= NULL_TREE
&& TREE_CODE (indexmode
) == ERROR_MARK
)
1525 return error_mark_node
;
1526 if (recordmode
!= NULL_TREE
&& TREE_CODE (recordmode
) == ERROR_MARK
)
1527 return error_mark_node
;
1529 datamode
= build_access_part ();
1531 type
= make_node (RECORD_TYPE
);
1532 listbase
= build_decl (FIELD_DECL
, get_identifier ("data"),
1534 TYPE_FIELDS (type
) = listbase
;
1535 decl
= build_lang_decl (TYPE_DECL
, get_identifier ("__recordmode"),
1536 recordmode
== NULL_TREE
? void_type_node
: recordmode
);
1537 chainon (listbase
, decl
);
1538 decl
= build_lang_decl (TYPE_DECL
, get_identifier ("__indexmode"),
1539 indexmode
== NULL_TREE
? void_type_node
: indexmode
);
1540 chainon (listbase
, decl
);
1541 decl
= build_decl (CONST_DECL
, get_identifier ("__dynamic"),
1543 DECL_INITIAL (decl
) = dynamic
? integer_one_node
: integer_zero_node
;
1544 chainon (listbase
, decl
);
1545 CH_IS_ACCESS_MODE (type
) = 1;
1546 CH_TYPE_NONVALUE_P (type
) = 1;
1551 returns a structure like
:
1552 STRUCT (txt
STRUCT (flags ULONG
,
1556 acc
STRUCT (flags ULONG
,
1564 tloc
CHARS(textlength
) VARYING
;
1567 TYPE_DECL __indexmode indexmode
? indexmode
: void_type_node
1568 CONST_DECL __text_length
1569 CONST_DECL __dynamic dynamic
? integer_one_node
: integer_zero_node
1572 build_text_mode (textlength
, indexmode
, dynamic
)
1577 tree txt
, acc
, listbase
, decl
, type
, tltype
;
1578 tree savedlength
= textlength
;
1580 if (indexmode
!= NULL_TREE
&& TREE_CODE (indexmode
) == ERROR_MARK
)
1581 return error_mark_node
;
1582 if (textlength
== NULL_TREE
|| TREE_CODE (textlength
) == ERROR_MARK
)
1583 return error_mark_node
;
1585 /* build the structure */
1586 listbase
= build_decl (FIELD_DECL
, get_identifier ("flags"),
1587 long_unsigned_type_node
);
1588 decl
= build_decl (FIELD_DECL
, get_identifier ("text_record"),
1590 listbase
= chainon (listbase
, decl
);
1591 decl
= build_decl (FIELD_DECL
, get_identifier ("access_sub"),
1593 listbase
= chainon (listbase
, decl
);
1594 decl
= build_decl (FIELD_DECL
, get_identifier ("actual_index"),
1595 long_integer_type_node
);
1596 listbase
= chainon (listbase
, decl
);
1597 txt
= build_chill_struct_type (listbase
);
1599 acc
= build_access_part ();
1601 type
= make_node (RECORD_TYPE
);
1602 listbase
= build_decl (FIELD_DECL
, get_identifier ("txt"), txt
);
1603 TYPE_FIELDS (type
) = listbase
;
1604 decl
= build_decl (FIELD_DECL
, get_identifier ("acc"), acc
);
1605 chainon (listbase
, decl
);
1606 /* the text location */
1607 tltype
= build_string_type (char_type_node
, textlength
);
1608 tltype
= build_varying_struct (tltype
);
1609 decl
= build_decl (FIELD_DECL
, get_identifier ("tloc"),
1611 chainon (listbase
, decl
);
1612 /* the index mode */
1613 decl
= build_lang_decl (TYPE_DECL
, get_identifier ("__indexmode"),
1614 indexmode
== NULL_TREE
? void_type_node
: indexmode
);
1615 chainon (listbase
, decl
);
1617 decl
= build_decl (CONST_DECL
, get_identifier ("__textlength"),
1619 if (TREE_CODE (textlength
) == COMPONENT_REF
)
1620 /* FIXME: we cannot use one and the same COMPONENT_REF twice, so build
1622 savedlength
= build_component_ref (TREE_OPERAND (textlength
, 0),
1623 TREE_OPERAND (textlength
, 1));
1624 DECL_INITIAL (decl
) = savedlength
;
1625 chainon (listbase
, decl
);
1627 decl
= build_decl (CONST_DECL
, get_identifier ("__dynamic"),
1629 DECL_INITIAL (decl
) = dynamic
? integer_one_node
: integer_zero_node
;
1630 chainon (listbase
, decl
);
1631 CH_IS_TEXT_MODE (type
) = 1;
1632 CH_TYPE_NONVALUE_P (type
) = 1;
1637 check_text_length (length
)
1640 if (length
== NULL_TREE
|| TREE_CODE (length
) == ERROR_MARK
)
1642 if (TREE_TYPE (length
) == NULL_TREE
1643 || !CH_SIMILAR (TREE_TYPE (length
), integer_type_node
))
1645 error ("non-integral text length");
1646 return integer_one_node
;
1648 if (TREE_CODE (length
) != INTEGER_CST
)
1650 error ("non-constant text length");
1651 return integer_one_node
;
1653 if (compare_int_csts (LE_EXPR
, length
, integer_zero_node
))
1655 error ("text length must be greater then 0");
1656 return integer_one_node
;
1662 text_indexmode (text
)
1667 if (text
== NULL_TREE
|| TREE_CODE (text
) == ERROR_MARK
)
1669 if (! CH_IS_TEXT_MODE (text
))
1672 field
= TYPE_FIELDS (text
);
1673 for ( ; field
!= NULL_TREE
; field
= TREE_CHAIN (field
))
1675 if (TREE_CODE (field
) == TYPE_DECL
)
1676 return TREE_TYPE (field
);
1678 return void_type_node
;
1687 if (text
== NULL_TREE
|| TREE_CODE (text
) == ERROR_MARK
)
1689 if (! CH_IS_TEXT_MODE (text
))
1692 field
= TYPE_FIELDS (text
);
1693 for ( ; field
!= NULL_TREE
; field
= TREE_CHAIN (field
))
1695 if (TREE_CODE (field
) == CONST_DECL
&&
1696 DECL_NAME (field
) == get_identifier ("__dynamic"))
1697 return DECL_INITIAL (field
);
1699 return integer_zero_node
;
1708 if (text
== NULL_TREE
|| TREE_CODE (text
) == ERROR_MARK
)
1710 if (! CH_IS_TEXT_MODE (text
))
1713 field
= TYPE_FIELDS (text
);
1714 for ( ; field
!= NULL_TREE
; field
= TREE_CHAIN (field
))
1716 if (TREE_CODE (field
) == CONST_DECL
&&
1717 DECL_NAME (field
) == get_identifier ("__textlength"))
1718 return DECL_INITIAL (field
);
1720 return integer_zero_node
;
1724 textlocation_mode (text
)
1729 if (text
== NULL_TREE
|| TREE_CODE (text
) == ERROR_MARK
)
1731 if (! CH_IS_TEXT_MODE (text
))
1734 field
= TYPE_FIELDS (text
);
1735 for ( ; field
!= NULL_TREE
; field
= TREE_CHAIN (field
))
1737 if (TREE_CODE (field
) == FIELD_DECL
&&
1738 DECL_NAME (field
) == get_identifier ("tloc"))
1739 return TREE_TYPE (field
);
1745 check_assoc (assoc
, argnum
, errmsg
)
1750 if (assoc
== NULL_TREE
|| TREE_CODE (assoc
) == ERROR_MARK
)
1753 if (! CH_IS_ASSOCIATION_MODE (TREE_TYPE (assoc
)))
1755 error ("argument %d of %s must be of mode ASSOCIATION", argnum
, errmsg
);
1758 if (! CH_LOCATION_P (assoc
))
1760 error ("argument %d of %s must be a location", argnum
, errmsg
);
1767 build_chill_associate (assoc
, fname
, attr
)
1772 tree arg1
= NULL_TREE
, arg2
= NULL_TREE
, arg3
= NULL_TREE
, arg4
= NULL_TREE
,
1773 arg5
= NULL_TREE
, arg6
, arg7
;
1777 /* make some checks */
1778 if (fname
== NULL_TREE
|| TREE_CODE (fname
) == ERROR_MARK
)
1779 return error_mark_node
;
1781 /* check the association */
1782 if (! check_assoc (assoc
, 1, "ASSOCIATION"))
1785 /* build a pointer to the association */
1786 arg1
= force_addr_of (assoc
);
1788 /* check the filename, must be a string */
1789 if (CH_CHARS_TYPE_P (TREE_TYPE (fname
)) ||
1790 (flag_old_strings
&& TREE_CODE (fname
) == INTEGER_CST
&&
1791 TREE_CODE (TREE_TYPE (fname
)) == CHAR_TYPE
))
1793 if (int_size_in_bytes (TREE_TYPE (fname
)) == 0)
1795 error ("argument 2 of ASSOCIATE must not be an empty string");
1800 arg2
= force_addr_of (fname
);
1801 arg3
= size_in_bytes (TREE_TYPE (fname
));
1804 else if (chill_varying_string_type_p (TREE_TYPE (fname
)))
1806 arg2
= force_addr_of (build_component_ref (fname
, var_data_id
));
1807 arg3
= build_component_ref (fname
, var_length_id
);
1811 error ("argument 2 to ASSOCIATE must be a string");
1815 /* check attr argument, must be a string too */
1816 if (attr
== NULL_TREE
)
1818 arg4
= null_pointer_node
;
1819 arg5
= integer_zero_node
;
1823 attr
= TREE_VALUE (attr
);
1824 if (attr
== NULL_TREE
|| TREE_CODE (attr
) == ERROR_MARK
)
1828 if (CH_CHARS_TYPE_P (TREE_TYPE (attr
)) ||
1829 (flag_old_strings
&& TREE_CODE (attr
) == INTEGER_CST
&&
1830 TREE_CODE (TREE_TYPE (attr
)) == CHAR_TYPE
))
1832 if (int_size_in_bytes (TREE_TYPE (attr
)) == 0)
1834 arg4
= null_pointer_node
;
1835 arg5
= integer_zero_node
;
1839 arg4
= force_addr_of (attr
);
1840 arg5
= size_in_bytes (TREE_TYPE (attr
));
1843 else if (chill_varying_string_type_p (TREE_TYPE (attr
)))
1845 arg4
= force_addr_of (build_component_ref (attr
, var_data_id
));
1846 arg5
= build_component_ref (attr
, var_length_id
);
1850 error ("argument 3 to ASSOCIATE must be a string");
1857 return error_mark_node
;
1859 /* other arguments */
1860 arg6
= force_addr_of (get_chill_filename ());
1861 arg7
= get_chill_linenumber ();
1863 result
= build_chill_function_call (
1864 lookup_name (get_identifier ("__associate")),
1865 tree_cons (NULL_TREE
, arg1
,
1866 tree_cons (NULL_TREE
, arg2
,
1867 tree_cons (NULL_TREE
, arg3
,
1868 tree_cons (NULL_TREE
, arg4
,
1869 tree_cons (NULL_TREE
, arg5
,
1870 tree_cons (NULL_TREE
, arg6
,
1871 tree_cons (NULL_TREE
, arg7
, NULL_TREE
))))))));
1873 TREE_TYPE (result
) = build_chill_pointer_type (TREE_TYPE (assoc
));
1878 assoc_call (assoc
, func
, name
)
1883 tree arg1
, arg2
, arg3
;
1886 if (! check_assoc (assoc
, 1, name
))
1887 return error_mark_node
;
1889 arg1
= force_addr_of (assoc
);
1890 arg2
= force_addr_of (get_chill_filename ());
1891 arg3
= get_chill_linenumber ();
1893 result
= build_chill_function_call (func
,
1894 tree_cons (NULL_TREE
, arg1
,
1895 tree_cons (NULL_TREE
, arg2
,
1896 tree_cons (NULL_TREE
, arg3
, NULL_TREE
))));
1901 build_chill_isassociated (assoc
)
1904 tree result
= assoc_call (assoc
,
1905 lookup_name (get_identifier ("__isassociated")),
1911 build_chill_existing (assoc
)
1914 tree result
= assoc_call (assoc
,
1915 lookup_name (get_identifier ("__existing")),
1921 build_chill_readable (assoc
)
1924 tree result
= assoc_call (assoc
,
1925 lookup_name (get_identifier ("__readable")),
1931 build_chill_writeable (assoc
)
1934 tree result
= assoc_call (assoc
,
1935 lookup_name (get_identifier ("__writeable")),
1941 build_chill_sequencible (assoc
)
1944 tree result
= assoc_call (assoc
,
1945 lookup_name (get_identifier ("__sequencible")),
1951 build_chill_variable (assoc
)
1954 tree result
= assoc_call (assoc
,
1955 lookup_name (get_identifier ("__variable")),
1961 build_chill_indexable (assoc
)
1964 tree result
= assoc_call (assoc
,
1965 lookup_name (get_identifier ("__indexable")),
1971 build_chill_dissociate (assoc
)
1974 tree result
= assoc_call (assoc
,
1975 lookup_name (get_identifier ("__dissociate")),
1981 build_chill_create (assoc
)
1984 tree result
= assoc_call (assoc
,
1985 lookup_name (get_identifier ("__create")),
1991 build_chill_delete (assoc
)
1994 tree result
= assoc_call (assoc
,
1995 lookup_name (get_identifier ("__delete")),
2001 build_chill_modify (assoc
, list
)
2005 tree arg1
= NULL_TREE
, arg2
= NULL_TREE
, arg3
= NULL_TREE
, arg4
= NULL_TREE
,
2006 arg5
= NULL_TREE
, arg6
, arg7
;
2007 int had_errors
= 0, numargs
;
2008 tree fname
= NULL_TREE
, attr
= NULL_TREE
;
2011 /* check the association */
2012 if (! check_assoc (assoc
, 1, "MODIFY"))
2015 arg1
= force_addr_of (assoc
);
2017 /* look how much arguments we have got */
2018 numargs
= list_length (list
);
2024 fname
= TREE_VALUE (list
);
2027 fname
= TREE_VALUE (list
);
2028 attr
= TREE_VALUE (TREE_CHAIN (list
));
2031 error ("Too many arguments in call to MODIFY");
2036 if (fname
!= NULL_TREE
&& fname
!= null_pointer_node
)
2038 if (CH_CHARS_TYPE_P (TREE_TYPE (fname
)) ||
2039 (flag_old_strings
&& TREE_CODE (fname
) == INTEGER_CST
&&
2040 TREE_CODE (TREE_TYPE (fname
)) == CHAR_TYPE
))
2042 if (int_size_in_bytes (TREE_TYPE (fname
)) == 0)
2044 error ("argument 2 of MODIFY must not be an empty string");
2049 arg2
= force_addr_of (fname
);
2050 arg3
= size_in_bytes (TREE_TYPE (fname
));
2053 else if (chill_varying_string_type_p (TREE_TYPE (fname
)))
2055 arg2
= force_addr_of (build_component_ref (fname
, var_data_id
));
2056 arg3
= build_component_ref (fname
, var_length_id
);
2060 error ("argument 2 to MODIFY must be a string");
2066 arg2
= null_pointer_node
;
2067 arg3
= integer_zero_node
;
2070 if (attr
!= NULL_TREE
&& attr
!= null_pointer_node
)
2072 if (CH_CHARS_TYPE_P (TREE_TYPE (attr
)) ||
2073 (flag_old_strings
&& TREE_CODE (attr
) == INTEGER_CST
&&
2074 TREE_CODE (TREE_TYPE (attr
)) == CHAR_TYPE
))
2076 if (int_size_in_bytes (TREE_TYPE (attr
)) == 0)
2078 arg4
= null_pointer_node
;
2079 arg5
= integer_zero_node
;
2083 arg4
= force_addr_of (attr
);
2084 arg5
= size_in_bytes (TREE_TYPE (attr
));
2087 else if (chill_varying_string_type_p (TREE_TYPE (attr
)))
2089 arg4
= force_addr_of (build_component_ref (attr
, var_data_id
));
2090 arg5
= build_component_ref (attr
, var_length_id
);
2094 error ("argument 3 to MODIFY must be a string");
2100 arg4
= null_pointer_node
;
2101 arg5
= integer_zero_node
;
2105 return error_mark_node
;
2107 /* other arguments */
2108 arg6
= force_addr_of (get_chill_filename ());
2109 arg7
= get_chill_linenumber ();
2111 result
= build_chill_function_call (
2112 lookup_name (get_identifier ("__modify")),
2113 tree_cons (NULL_TREE
, arg1
,
2114 tree_cons (NULL_TREE
, arg2
,
2115 tree_cons (NULL_TREE
, arg3
,
2116 tree_cons (NULL_TREE
, arg4
,
2117 tree_cons (NULL_TREE
, arg5
,
2118 tree_cons (NULL_TREE
, arg6
,
2119 tree_cons (NULL_TREE
, arg7
, NULL_TREE
))))))));
2125 check_transfer (transfer
, argnum
, errmsg
)
2132 if (transfer
== NULL_TREE
|| TREE_CODE (transfer
) == ERROR_MARK
)
2135 if (CH_IS_ACCESS_MODE (TREE_TYPE (transfer
)))
2137 else if (CH_IS_TEXT_MODE (TREE_TYPE (transfer
)))
2141 error ("argument %d of %s must be an ACCESS or TEXT mode", argnum
, errmsg
);
2144 if (! CH_LOCATION_P (transfer
))
2146 error ("argument %d of %s must be a location", argnum
, errmsg
);
2152 /* define bits in an access/text flag word.
2153 NOTE: this must be consistent with runtime/iomodes.h */
2154 #define IO_TEXTLOCATION 0x80000000
2155 #define IO_INDEXED 0x00000001
2156 #define IO_TEXTIO 0x00000002
2157 #define IO_OUTOFFILE 0x00010000
2159 /* generated initialisation code for ACCESS and TEXT.
2160 functions gets called from do_decl. */
2161 void init_access_location (decl
, type
)
2165 tree recordmode
= access_recordmode (type
);
2166 tree indexmode
= access_indexmode (type
);
2168 tree data
= build_component_ref (decl
, get_identifier ("data"));
2169 tree lowindex
= integer_zero_node
;
2170 tree highindex
= integer_zero_node
;
2171 tree rectype
, reclen
;
2174 if (indexmode
!= NULL_TREE
&& indexmode
!= void_type_node
)
2176 flags_init
|= IO_INDEXED
;
2177 lowindex
= convert (integer_type_node
, TYPE_MIN_VALUE (indexmode
));
2178 highindex
= convert (integer_type_node
, TYPE_MAX_VALUE (indexmode
));
2182 build_chill_modify_expr (
2183 build_component_ref (data
, get_identifier ("flags")),
2184 build_int_2 (flags_init
, 0)));
2187 if (recordmode
== NULL_TREE
|| recordmode
== void_type_node
)
2189 reclen
= integer_zero_node
;
2190 rectype
= integer_zero_node
;
2192 else if (chill_varying_string_type_p (recordmode
))
2194 tree fields
= TYPE_FIELDS (recordmode
);
2197 /* don't count any padding bytes at end of varying */
2198 len1
= size_in_bytes (TREE_TYPE (fields
));
2199 fields
= TREE_CHAIN (fields
);
2200 len2
= size_in_bytes (TREE_TYPE (fields
));
2201 reclen
= fold (build (PLUS_EXPR
, long_integer_type_node
, len1
, len2
));
2202 rectype
= build_int_2 (2, 0);
2206 reclen
= size_in_bytes (recordmode
);
2207 rectype
= integer_one_node
;
2210 build_chill_modify_expr (
2211 build_component_ref (data
, get_identifier ("reclength")), reclen
));
2215 build_chill_modify_expr (
2216 build_component_ref (data
, get_identifier ("rectype")), rectype
));
2220 build_chill_modify_expr (
2221 build_component_ref (data
, get_identifier ("lowindex")), lowindex
));
2223 build_chill_modify_expr (
2224 build_component_ref (data
, get_identifier ("highindex")), highindex
));
2228 build_chill_modify_expr (
2229 build_chill_component_ref (data
, get_identifier ("association")),
2230 null_pointer_node
));
2234 build_chill_modify_expr (
2235 build_component_ref (data
, get_identifier ("storelocptr")), null_pointer_node
));
2238 void init_text_location (decl
, type
)
2242 tree indexmode
= text_indexmode (type
);
2243 unsigned long accessflags
= 0;
2244 unsigned long textflags
= IO_TEXTLOCATION
;
2245 tree lowindex
= integer_zero_node
;
2246 tree highindex
= integer_zero_node
;
2247 tree data
, tloc
, tlocfields
, len1
, len2
, reclen
;
2249 if (indexmode
!= NULL_TREE
&& indexmode
!= void_type_node
)
2251 accessflags
|= IO_INDEXED
;
2252 lowindex
= convert (integer_type_node
, TYPE_MIN_VALUE (indexmode
));
2253 highindex
= convert (integer_type_node
, TYPE_MAX_VALUE (indexmode
));
2256 tloc
= build_component_ref (decl
, get_identifier ("tloc"));
2257 /* fill access part of text location */
2258 data
= build_component_ref (decl
, get_identifier ("acc"));
2261 build_chill_modify_expr (
2262 build_component_ref (data
, get_identifier ("flags")),
2263 build_int_2 (accessflags
, 0)));
2265 /* record length, don't count any padding bytes at end of varying */
2266 tlocfields
= TYPE_FIELDS (TREE_TYPE (tloc
));
2267 len1
= size_in_bytes (TREE_TYPE (tlocfields
));
2268 tlocfields
= TREE_CHAIN (tlocfields
);
2269 len2
= size_in_bytes (TREE_TYPE (tlocfields
));
2270 reclen
= fold (build (PLUS_EXPR
, long_integer_type_node
, len1
, len2
));
2272 build_chill_modify_expr (
2273 build_component_ref (data
, get_identifier ("reclength")),
2278 build_chill_modify_expr (
2279 build_component_ref (data
, get_identifier ("lowindex")), lowindex
));
2281 build_chill_modify_expr (
2282 build_component_ref (data
, get_identifier ("highindex")), highindex
));
2286 build_chill_modify_expr (
2287 build_chill_component_ref (data
, get_identifier ("association")),
2288 null_pointer_node
));
2292 build_chill_modify_expr (
2293 build_component_ref (data
, get_identifier ("storelocptr")),
2294 null_pointer_node
));
2298 build_chill_modify_expr (
2299 build_component_ref (data
, get_identifier ("rectype")),
2300 build_int_2 (2, 0))); /* VaryingChars */
2302 /* fill text part */
2303 data
= build_component_ref (decl
, get_identifier ("txt"));
2306 build_chill_modify_expr (
2307 build_component_ref (data
, get_identifier ("flags")),
2308 build_int_2 (textflags
, 0)));
2310 /* pointer to text record */
2312 build_chill_modify_expr (
2313 build_component_ref (data
, get_identifier ("text_record")),
2314 force_addr_of (tloc
)));
2316 /* pointer to the access */
2318 build_chill_modify_expr (
2319 build_component_ref (data
, get_identifier ("access_sub")),
2320 force_addr_of (build_component_ref (decl
, get_identifier ("acc")))));
2324 build_chill_modify_expr (
2325 build_component_ref (data
, get_identifier ("actual_index")),
2326 integer_zero_node
));
2328 /* length of text record */
2330 build_chill_modify_expr (
2331 build_component_ref (tloc
, get_identifier (VAR_LENGTH
)),
2332 integer_zero_node
));
2336 connect_process_optionals (optionals
, whereptr
, indexptr
, indexmode
)
2342 tree where
= NULL_TREE
, theindex
= NULL_TREE
;
2345 if (optionals
!= NULL_TREE
)
2347 /* get the where expression */
2348 where
= TREE_VALUE (optionals
);
2349 if (where
== NULL_TREE
|| TREE_CODE (where
) == ERROR_MARK
)
2353 if (! CH_IS_WHERE_MODE (TREE_TYPE (where
)))
2355 error ("argument 4 of CONNECT must be of mode WHERE");
2358 where
= convert (integer_type_node
, where
);
2360 optionals
= TREE_CHAIN (optionals
);
2362 if (optionals
!= NULL_TREE
)
2364 theindex
= TREE_VALUE (optionals
);
2365 if (theindex
== NULL_TREE
|| TREE_CODE (theindex
) == ERROR_MARK
)
2369 if (indexmode
== void_type_node
)
2371 error ("index expression for ACCESS without index");
2374 else if (! CH_COMPATIBLE (theindex
, indexmode
))
2376 error ("incompatible index mode");
2385 *indexptr
= theindex
;
2390 connect_text (assoc
, text
, usage
, optionals
)
2396 tree where
= NULL_TREE
, theindex
= NULL_TREE
;
2397 tree indexmode
= text_indexmode (TREE_TYPE (text
));
2398 tree result
, what_where
, have_index
, what_index
;
2400 /* process optionals */
2401 if (!connect_process_optionals (optionals
, &where
, &theindex
, indexmode
))
2402 return error_mark_node
;
2404 what_where
= where
== NULL_TREE
? integer_zero_node
: where
;
2405 have_index
= theindex
== NULL_TREE
? integer_zero_node
2407 what_index
= theindex
== NULL_TREE
? integer_zero_node
2408 : convert (integer_type_node
, theindex
);
2409 result
= build_chill_function_call (
2410 lookup_name (get_identifier ("__connect")),
2411 tree_cons (NULL_TREE
, force_addr_of (text
),
2412 tree_cons (NULL_TREE
, force_addr_of (assoc
),
2413 tree_cons (NULL_TREE
, convert (integer_type_node
, usage
),
2414 tree_cons (NULL_TREE
, what_where
,
2415 tree_cons (NULL_TREE
, have_index
,
2416 tree_cons (NULL_TREE
, what_index
,
2417 tree_cons (NULL_TREE
, force_addr_of (get_chill_filename ()),
2418 tree_cons (NULL_TREE
, get_chill_linenumber (),
2424 connect_access (assoc
, transfer
, usage
, optionals
)
2430 tree where
= NULL_TREE
, theindex
= NULL_TREE
;
2431 tree indexmode
= access_indexmode (TREE_TYPE (transfer
));
2432 tree result
, what_where
, have_index
, what_index
;
2434 /* process the optionals */
2435 if (! connect_process_optionals (optionals
, &where
, &theindex
, indexmode
))
2436 return error_mark_node
;
2439 what_where
= where
== NULL_TREE
? integer_zero_node
: where
;
2440 have_index
= theindex
== NULL_TREE
? integer_zero_node
: integer_one_node
;
2441 what_index
= theindex
== NULL_TREE
? integer_zero_node
: convert (integer_type_node
, theindex
);
2442 result
= build_chill_function_call (
2443 lookup_name (get_identifier ("__connect")),
2444 tree_cons (NULL_TREE
, force_addr_of (transfer
),
2445 tree_cons (NULL_TREE
, force_addr_of (assoc
),
2446 tree_cons (NULL_TREE
, convert (integer_type_node
, usage
),
2447 tree_cons (NULL_TREE
, what_where
,
2448 tree_cons (NULL_TREE
, have_index
,
2449 tree_cons (NULL_TREE
, what_index
,
2450 tree_cons (NULL_TREE
, force_addr_of (get_chill_filename ()),
2451 tree_cons (NULL_TREE
, get_chill_linenumber (),
2457 build_chill_connect (transfer
, assoc
, usage
, optionals
)
2465 tree result
= error_mark_node
;
2467 if (! check_assoc (assoc
, 2, "CONNECT"))
2471 if (usage
== NULL_TREE
|| TREE_CODE (usage
) == ERROR_MARK
)
2472 return error_mark_node
;
2474 if (! CH_IS_USAGE_MODE (TREE_TYPE (usage
)))
2476 error ("argument 3 to CONNECT must be of mode USAGE");
2480 return error_mark_node
;
2482 /* look what we have got */
2483 what
= check_transfer (transfer
, 1, "CONNECT");
2487 /* we have an ACCESS */
2488 result
= connect_access (assoc
, transfer
, usage
, optionals
);
2491 /* we have a TEXT */
2492 result
= connect_text (assoc
, transfer
, usage
, optionals
);
2495 result
= error_mark_node
;
2501 check_access (access
, argnum
, errmsg
)
2506 if (access
== NULL_TREE
|| TREE_CODE (access
) == ERROR_MARK
)
2509 if (! CH_IS_ACCESS_MODE (TREE_TYPE (access
)))
2511 error ("argument %d of %s must be of mode ACCESS", argnum
, errmsg
);
2514 if (! CH_LOCATION_P (access
))
2516 error ("argument %d of %s must be a location", argnum
, errmsg
);
2523 build_chill_readrecord (access
, optionals
)
2528 tree recordmode
, indexmode
, dynamic
, result
;
2529 tree index
= NULL_TREE
, location
= NULL_TREE
;
2531 if (! check_access (access
, 1, "READRECORD"))
2532 return error_mark_node
;
2534 recordmode
= access_recordmode (TREE_TYPE (access
));
2535 indexmode
= access_indexmode (TREE_TYPE (access
));
2536 dynamic
= access_dynamic (TREE_TYPE (access
));
2538 /* process the optionals */
2539 len
= list_length (optionals
);
2540 if (indexmode
!= void_type_node
)
2542 /* we must have an index */
2545 error ("Too few arguments in call to `readrecord'");
2546 return error_mark_node
;
2548 index
= TREE_VALUE (optionals
);
2549 if (index
== NULL_TREE
|| TREE_CODE (index
) == ERROR_MARK
)
2550 return error_mark_node
;
2551 optionals
= TREE_CHAIN (optionals
);
2552 if (! CH_COMPATIBLE (index
, indexmode
))
2554 error ("incompatible index mode");
2555 return error_mark_node
;
2559 /* check the record mode, if one */
2560 if (optionals
!= NULL_TREE
)
2562 location
= TREE_VALUE (optionals
);
2563 if (location
== NULL_TREE
|| TREE_CODE (location
) == ERROR_MARK
)
2564 return error_mark_node
;
2565 if (recordmode
!= void_type_node
&&
2566 ! CH_COMPATIBLE (location
, recordmode
))
2569 error ("incompatible record mode");
2570 return error_mark_node
;
2572 if (TYPE_READONLY_PROPERTY (TREE_TYPE (location
)))
2574 error ("store location must not be READonly");
2575 return error_mark_node
;
2577 location
= force_addr_of (location
);
2580 location
= null_pointer_node
;
2582 index
= index
== NULL_TREE
? integer_zero_node
: convert (integer_type_node
, index
);
2583 result
= build_chill_function_call (
2584 lookup_name (get_identifier ("__readrecord")),
2585 tree_cons (NULL_TREE
, force_addr_of (access
),
2586 tree_cons (NULL_TREE
, index
,
2587 tree_cons (NULL_TREE
, location
,
2588 tree_cons (NULL_TREE
, force_addr_of (get_chill_filename ()),
2589 tree_cons (NULL_TREE
, get_chill_linenumber (), NULL_TREE
))))));
2591 TREE_TYPE (result
) = build_chill_pointer_type (recordmode
);
2596 build_chill_writerecord (access
, optionals
)
2600 int had_errors
= 0, len
;
2601 tree recordmode
, indexmode
, dynamic
;
2602 tree index
= NULL_TREE
, location
= NULL_TREE
;
2605 if (! check_access (access
, 1, "WRITERECORD"))
2606 return error_mark_node
;
2608 recordmode
= access_recordmode (TREE_TYPE (access
));
2609 indexmode
= access_indexmode (TREE_TYPE (access
));
2610 dynamic
= access_dynamic (TREE_TYPE (access
));
2612 /* process the optionals */
2613 len
= list_length (optionals
);
2614 if (indexmode
!= void_type_node
&& len
!= 2)
2616 error ("Too few arguments in call to `writerecord'");
2617 return error_mark_node
;
2619 if (indexmode
!= void_type_node
)
2621 index
= TREE_VALUE (optionals
);
2622 if (index
== NULL_TREE
|| TREE_CODE (index
) == ERROR_MARK
)
2623 return error_mark_node
;
2624 location
= TREE_VALUE (TREE_CHAIN (optionals
));
2625 if (location
== NULL_TREE
|| TREE_CODE (location
) == ERROR_MARK
)
2626 return error_mark_node
;
2629 location
= TREE_VALUE (optionals
);
2631 /* check the index */
2632 if (indexmode
!= void_type_node
)
2634 if (! CH_COMPATIBLE (index
, indexmode
))
2636 error ("incompatible index mode");
2640 /* check the record mode */
2641 if (recordmode
== void_type_node
)
2643 error ("transfer to ACCESS without record mode");
2646 else if (! CH_COMPATIBLE (location
, recordmode
))
2648 error ("incompatible record mode");
2652 return error_mark_node
;
2654 index
= index
== NULL_TREE
? integer_zero_node
: convert (integer_type_node
, index
);
2656 result
= build_chill_function_call (
2657 lookup_name (get_identifier ("__writerecord")),
2658 tree_cons (NULL_TREE
, force_addr_of (access
),
2659 tree_cons (NULL_TREE
, index
,
2660 tree_cons (NULL_TREE
, force_addr_of (location
),
2661 tree_cons (NULL_TREE
, size_in_bytes (TREE_TYPE (location
)),
2662 tree_cons (NULL_TREE
, force_addr_of (get_chill_filename ()),
2663 tree_cons (NULL_TREE
, get_chill_linenumber (), NULL_TREE
)))))));
2668 build_chill_disconnect (transfer
)
2673 if (! check_transfer (transfer
, 1, "DISCONNECT"))
2674 return error_mark_node
;
2675 result
= build_chill_function_call (
2676 lookup_name (get_identifier ("__disconnect")),
2677 tree_cons (NULL_TREE
, force_addr_of (transfer
),
2678 tree_cons (NULL_TREE
, force_addr_of (get_chill_filename ()),
2679 tree_cons (NULL_TREE
, get_chill_linenumber (), NULL_TREE
))));
2684 build_chill_getassociation (transfer
)
2689 if (! check_transfer (transfer
, 1, "GETASSOCIATION"))
2690 return error_mark_node
;
2692 result
= build_chill_function_call (
2693 lookup_name (get_identifier ("__getassociation")),
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
) = build_chill_pointer_type (association_type_node
);
2702 build_chill_getusage (transfer
)
2707 if (! check_transfer (transfer
, 1, "GETUSAGE"))
2708 return error_mark_node
;
2710 result
= build_chill_function_call (
2711 lookup_name (get_identifier ("__getusage")),
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
))));
2715 TREE_TYPE (result
) = usage_type_node
;
2720 build_chill_outoffile (transfer
)
2725 if (! check_transfer (transfer
, 1, "OUTOFFILE"))
2726 return error_mark_node
;
2728 result
= build_chill_function_call (
2729 lookup_name (get_identifier ("__outoffile")),
2730 tree_cons (NULL_TREE
, force_addr_of (transfer
),
2731 tree_cons (NULL_TREE
, force_addr_of (get_chill_filename ()),
2732 tree_cons (NULL_TREE
, get_chill_linenumber (), NULL_TREE
))));
2737 check_text (text
, argnum
, errmsg
)
2742 if (text
== NULL_TREE
|| TREE_CODE (text
) == ERROR_MARK
)
2744 if (! CH_IS_TEXT_MODE (TREE_TYPE (text
)))
2746 error ("argument %d of %s must be of mode TEXT", argnum
, errmsg
);
2749 if (! CH_LOCATION_P (text
))
2751 error ("argument %d of %s must be a location", argnum
, errmsg
);
2758 build_chill_eoln (text
)
2763 if (! check_text (text
, 1, "EOLN"))
2764 return error_mark_node
;
2766 result
= build_chill_function_call (
2767 lookup_name (get_identifier ("__eoln")),
2768 tree_cons (NULL_TREE
, force_addr_of (text
),
2769 tree_cons (NULL_TREE
, force_addr_of (get_chill_filename ()),
2770 tree_cons (NULL_TREE
, get_chill_linenumber (), NULL_TREE
))));
2775 build_chill_gettextindex (text
)
2780 if (! check_text (text
, 1, "GETTEXTINDEX"))
2781 return error_mark_node
;
2783 result
= build_chill_function_call (
2784 lookup_name (get_identifier ("__gettextindex")),
2785 tree_cons (NULL_TREE
, force_addr_of (text
),
2786 tree_cons (NULL_TREE
, force_addr_of (get_chill_filename ()),
2787 tree_cons (NULL_TREE
, get_chill_linenumber (), NULL_TREE
))));
2792 build_chill_gettextrecord (text
)
2795 tree textmode
, result
;
2797 if (! check_text (text
, 1, "GETTEXTRECORD"))
2798 return error_mark_node
;
2800 textmode
= textlocation_mode (TREE_TYPE (text
));
2801 if (textmode
== NULL_TREE
)
2803 error ("TEXT doesn't have a location"); /* FIXME */
2804 return error_mark_node
;
2806 result
= build_chill_function_call (
2807 lookup_name (get_identifier ("__gettextrecord")),
2808 tree_cons (NULL_TREE
, force_addr_of (text
),
2809 tree_cons (NULL_TREE
, force_addr_of (get_chill_filename ()),
2810 tree_cons (NULL_TREE
, get_chill_linenumber (), NULL_TREE
))));
2811 TREE_TYPE (result
) = build_chill_pointer_type (textmode
);
2812 CH_DERIVED_FLAG (result
) = 1;
2817 build_chill_gettextaccess (text
)
2820 tree access
, refaccess
, acc
, decl
, listbase
;
2821 tree tlocmode
, indexmode
, dynamic
;
2823 unsigned int save_maximum_field_alignment
= maximum_field_alignment
;
2825 if (! check_text (text
, 1, "GETTEXTACCESS"))
2826 return error_mark_node
;
2828 tlocmode
= textlocation_mode (TREE_TYPE (text
));
2829 indexmode
= text_indexmode (TREE_TYPE (text
));
2830 dynamic
= text_dynamic (TREE_TYPE (text
));
2832 /* we have to build a type for the access */
2833 acc
= build_access_part ();
2834 access
= make_node (RECORD_TYPE
);
2835 listbase
= build_decl (FIELD_DECL
, get_identifier ("data"), acc
);
2836 TYPE_FIELDS (access
) = listbase
;
2837 decl
= build_lang_decl (TYPE_DECL
, get_identifier ("__recordmode"),
2839 chainon (listbase
, decl
);
2840 decl
= build_lang_decl (TYPE_DECL
, get_identifier ("__indexmode"),
2842 chainon (listbase
, decl
);
2843 decl
= build_decl (CONST_DECL
, get_identifier ("__dynamic"),
2845 DECL_INITIAL (decl
) = dynamic
;
2846 chainon (listbase
, decl
);
2847 maximum_field_alignment
= 0;
2848 layout_chill_struct_type (access
);
2849 maximum_field_alignment
= save_maximum_field_alignment
;
2850 CH_IS_ACCESS_MODE (access
) = 1;
2851 CH_TYPE_NONVALUE_P (access
) = 1;
2853 refaccess
= build_chill_pointer_type (access
);
2855 result
= build_chill_function_call (
2856 lookup_name (get_identifier ("__gettextaccess")),
2857 tree_cons (NULL_TREE
, force_addr_of (text
),
2858 tree_cons (NULL_TREE
, force_addr_of (get_chill_filename ()),
2859 tree_cons (NULL_TREE
, get_chill_linenumber (), NULL_TREE
))));
2860 TREE_TYPE (result
) = refaccess
;
2861 CH_DERIVED_FLAG (result
) = 1;
2866 build_chill_settextindex (text
, expr
)
2872 if (! check_text (text
, 1, "SETTEXTINDEX"))
2873 return error_mark_node
;
2874 if (expr
== NULL_TREE
|| TREE_CODE (expr
) == ERROR_MARK
)
2875 return error_mark_node
;
2876 result
= build_chill_function_call (
2877 lookup_name (get_identifier ("__settextindex")),
2878 tree_cons (NULL_TREE
, force_addr_of (text
),
2879 tree_cons (NULL_TREE
, expr
,
2880 tree_cons (NULL_TREE
, force_addr_of (get_chill_filename ()),
2881 tree_cons (NULL_TREE
, get_chill_linenumber (), NULL_TREE
)))));
2886 build_chill_settextaccess (text
, access
)
2891 tree textindexmode
, accessindexmode
;
2892 tree textrecordmode
, accessrecordmode
;
2894 if (! check_text (text
, 1, "SETTEXTACCESS"))
2895 return error_mark_node
;
2896 if (! check_access (access
, 2, "SETTEXTACCESS"))
2897 return error_mark_node
;
2899 textindexmode
= text_indexmode (TREE_TYPE (text
));
2900 accessindexmode
= access_indexmode (TREE_TYPE (access
));
2901 if (textindexmode
!= accessindexmode
)
2903 if (! chill_read_compatible (textindexmode
, accessindexmode
))
2905 error ("incompatible index mode for SETETEXTACCESS");
2906 return error_mark_node
;
2909 textrecordmode
= textlocation_mode (TREE_TYPE (text
));
2910 accessrecordmode
= access_recordmode (TREE_TYPE (access
));
2911 if (textrecordmode
!= accessrecordmode
)
2913 if (! chill_read_compatible (textrecordmode
, accessrecordmode
))
2915 error ("incompatible record mode for SETTEXTACCESS");
2916 return error_mark_node
;
2919 result
= build_chill_function_call (
2920 lookup_name (get_identifier ("__settextaccess")),
2921 tree_cons (NULL_TREE
, force_addr_of (text
),
2922 tree_cons (NULL_TREE
, force_addr_of (access
),
2923 tree_cons (NULL_TREE
, force_addr_of (get_chill_filename ()),
2924 tree_cons (NULL_TREE
, get_chill_linenumber (), NULL_TREE
)))));
2929 build_chill_settextrecord (text
, charloc
)
2937 if (! check_text (text
, 1, "SETTEXTRECORD"))
2938 return error_mark_node
;
2939 if (charloc
== NULL_TREE
|| TREE_CODE (charloc
) == ERROR_MARK
)
2940 return error_mark_node
;
2942 /* check the location */
2943 if (! CH_LOCATION_P (charloc
))
2945 error ("parameter 2 must be a location");
2946 return error_mark_node
;
2948 tlocmode
= textlocation_mode (TREE_TYPE (text
));
2949 if (! chill_varying_string_type_p (TREE_TYPE (charloc
)))
2951 else if (int_size_in_bytes (tlocmode
) != int_size_in_bytes (TREE_TYPE (charloc
)))
2955 error ("incompatible modes in parameter 2");
2956 return error_mark_node
;
2958 result
= build_chill_function_call (
2959 lookup_name (get_identifier ("__settextrecord")),
2960 tree_cons (NULL_TREE
, force_addr_of (text
),
2961 tree_cons (NULL_TREE
, force_addr_of (charloc
),
2962 tree_cons (NULL_TREE
, force_addr_of (get_chill_filename ()),
2963 tree_cons (NULL_TREE
, get_chill_linenumber (), NULL_TREE
)))));
2967 /* process iolist for READ- and WRITETEXT */
2969 /* function walks through types as long as they are ranges,
2970 returns the type and min- and max-value form starting type.
2974 get_final_type_and_range (item
, low
, high
)
2981 *low
= TYPE_MIN_VALUE (wrk
);
2982 *high
= TYPE_MAX_VALUE (wrk
);
2983 while (TREE_CODE (wrk
) == INTEGER_TYPE
&&
2984 TREE_TYPE (wrk
) != NULL_TREE
&&
2985 TREE_CODE (TREE_TYPE (wrk
)) == INTEGER_TYPE
&&
2986 TREE_TYPE (TREE_TYPE (wrk
)) != NULL_TREE
)
2987 wrk
= TREE_TYPE (wrk
);
2989 return (TREE_TYPE (wrk
));
2993 process_io_list (exprlist
, iolist_addr
, iolist_length
, iolist_rtx
, do_read
,
2997 tree
*iolist_length
;
3005 tree iolisttype
, iolist
;
3007 if (exprlist
== NULL_TREE
)
3010 iolen
= list_length (exprlist
);
3012 /* build indexlist for the io list */
3013 idxlist
= build_tree_list (NULL_TREE
,
3014 build_chill_range_type (NULL_TREE
,
3016 build_int_2 (iolen
, 0)));
3018 /* build the io-list type */
3019 iolisttype
= build_chill_array_type (TREE_TYPE (chill_io_list_type
),
3020 idxlist
, 0, NULL_TREE
);
3022 /* declare the iolist */
3023 iolist
= build_decl (VAR_DECL
, get_unique_identifier (do_read
? "RDTEXT" : "WRTEXT"),
3026 /* we want to get a variable which gets marked unused after
3027 the function call, This is a little bit tricky cause the
3028 address of this variable will be taken and therefor the variable
3029 gets moved out one level. However, we REALLY don't need this
3030 variable again. Solution: push 2 levels and do pop and free
3031 twice at the end. */
3034 *iolist_rtx
= assign_temp (TREE_TYPE (iolist
), 0, 1, 0);
3035 DECL_RTL (iolist
) = *iolist_rtx
;
3037 /* process the exprlist */
3039 while (exprlist
!= NULL_TREE
)
3041 tree item
= TREE_VALUE (exprlist
);
3042 tree idx
= build_int_2 (idxcnt
++, 0);
3043 const char *fieldname
= 0;
3044 const char *enumname
= 0;
3045 tree array_ref
= build_chill_array_ref_1 (iolist
, idx
);
3047 tree range_low
= NULL_TREE
, range_high
= NULL_TREE
;
3049 tree item_addr
= null_pointer_node
;
3053 /* next value in exprlist */
3054 exprlist
= TREE_CHAIN (exprlist
);
3055 if (item
== NULL_TREE
|| TREE_CODE (item
) == ERROR_MARK
)
3058 item_type
= TREE_TYPE (item
);
3059 if (item_type
== NULL_TREE
)
3061 if (TREE_CODE (item
) == COND_EXPR
|| TREE_CODE (item
) == CASE_EXPR
)
3062 error ("conditional expression not allowed in this context");
3064 error ("untyped expression as argument %d", idxcnt
+ 1 + argoffset
);
3067 else if (TREE_CODE (item_type
) == ERROR_MARK
)
3070 if (TREE_CODE (item_type
) == REFERENCE_TYPE
)
3072 item_type
= TREE_TYPE (item_type
);
3073 item
= convert (item_type
, item
);
3076 /* check for a range */
3077 if (TREE_CODE (item_type
) == INTEGER_TYPE
&&
3078 TREE_TYPE (item_type
) != NULL_TREE
)
3080 /* we have a range. NOTE, however, on writetext we don't process ranges */
3081 item_type
= get_final_type_and_range (item_type
,
3082 &range_low
, &range_high
);
3086 readonly
= TYPE_READONLY_PROPERTY (item_type
);
3087 referable
= CH_REFERABLE (item
);
3089 item_addr
= force_addr_of (item
);
3090 /* if we are in read and have readonly we can't do this */
3091 if (readonly
&& do_read
)
3093 item_addr
= null_pointer_node
;
3097 /* process different types */
3098 if (TREE_CODE (item_type
) == INTEGER_TYPE
)
3100 int type_size
= TREE_INT_CST_LOW (TYPE_SIZE (item_type
));
3101 tree to_assign
= NULL_TREE
;
3103 if (do_read
&& referable
)
3105 /* process an integer in case of READTEXT and expression is
3106 referable and not READONLY */
3107 to_assign
= item_addr
;
3110 /* do it for a range */
3111 tree t
, __forxx
, __ptr
, __low
, __high
;
3112 tree what_upper
, what_lower
;
3114 /* determine the name in the union of lower and upper */
3115 if (TREE_UNSIGNED (item_type
))
3116 fieldname
= "_ulong";
3118 fieldname
= "_slong";
3123 if (TREE_UNSIGNED (item_type
))
3124 enumname
= "__IO_UByteRangeLoc";
3126 enumname
= "__IO_ByteRangeLoc";
3129 if (TREE_UNSIGNED (item_type
))
3130 enumname
= "__IO_UIntRangeLoc";
3132 enumname
= "__IO_IntRangeLoc";
3135 if (TREE_UNSIGNED (item_type
))
3136 enumname
= "__IO_ULongRangeLoc";
3138 enumname
= "__IO_LongRangeLoc";
3141 error ("Cannot process %d bits integer for READTEXT argument %d.",
3142 type_size
, idxcnt
+ 1 + argoffset
);
3146 /* set up access to structure */
3147 t
= build_component_ref (array_ref
,
3148 get_identifier ("__t"));
3149 __forxx
= build_component_ref (t
, get_identifier ("__locintrange"));
3150 __ptr
= build_component_ref (__forxx
, get_identifier ("ptr"));
3151 __low
= build_component_ref (__forxx
, get_identifier ("lower"));
3152 what_lower
= build_component_ref (__low
, get_identifier (fieldname
));
3153 __high
= build_component_ref (__forxx
, get_identifier ("upper"));
3154 what_upper
= build_component_ref (__high
, get_identifier (fieldname
));
3156 /* do the assignments */
3157 expand_assignment (__ptr
, item_addr
, 0, 0);
3158 expand_assignment (what_lower
, range_low
, 0, 0);
3159 expand_assignment (what_upper
, range_high
, 0, 0);
3165 fieldname
= "__locint";
3169 if (TREE_UNSIGNED (item_type
))
3170 enumname
= "__IO_UByteLoc";
3172 enumname
= "__IO_ByteLoc";
3175 if (TREE_UNSIGNED (item_type
))
3176 enumname
= "__IO_UIntLoc";
3178 enumname
= "__IO_IntLoc";
3181 if (TREE_UNSIGNED (item_type
))
3182 enumname
= "__IO_ULongLoc";
3184 enumname
= "__IO_LongLoc";
3187 error ("Cannot process %d bits integer for READTEXT argument %d.",
3188 type_size
, idxcnt
+ 1 + argoffset
);
3195 /* process an integer in case of WRITETEXT */
3200 if (TREE_UNSIGNED (item_type
))
3202 enumname
= "__IO_UByteVal";
3203 fieldname
= "__valubyte";
3207 enumname
= "__IO_ByteVal";
3208 fieldname
= "__valbyte";
3212 if (TREE_UNSIGNED (item_type
))
3214 enumname
= "__IO_UIntVal";
3215 fieldname
= "__valuint";
3219 enumname
= "__IO_IntVal";
3220 fieldname
= "__valint";
3225 if (TREE_UNSIGNED (item_type
))
3227 enumname
= "__IO_ULongVal";
3228 fieldname
= "__valulong";
3232 enumname
= "__IO_LongVal";
3233 fieldname
= "__vallong";
3237 /* convert it back to {unsigned}long. */
3238 if (TREE_UNSIGNED (item_type
))
3239 item_type
= long_unsigned_type_node
;
3241 item_type
= long_integer_type_node
;
3242 item
= convert (item_type
, item
);
3245 /* This kludge is because the lexer gives literals
3246 the type long_long_{integer,unsigned}_type_node. */
3247 if (TREE_CODE (item
) == INTEGER_CST
)
3249 if (int_fits_type_p (item
, long_integer_type_node
))
3251 item_type
= long_integer_type_node
;
3252 item
= convert (item_type
, item
);
3255 if (int_fits_type_p (item
, long_unsigned_type_node
))
3257 item_type
= long_unsigned_type_node
;
3258 item
= convert (item_type
, item
);
3262 error ("Cannot process %d bits integer WRITETEXT argument %d.",
3263 type_size
, idxcnt
+ 1 + argoffset
);
3271 t
= build_component_ref (array_ref
,
3272 get_identifier ("__t"));
3273 __forxx
= build_component_ref (t
, get_identifier (fieldname
));
3274 expand_assignment (__forxx
, to_assign
, 0, 0);
3277 else if (TREE_CODE (item_type
) == CHAR_TYPE
)
3279 tree to_assign
= NULL_TREE
;
3281 if (do_read
&& readonly
)
3283 error ("argument %d is READonly", idxcnt
+ 1 + argoffset
);
3290 error ("argument %d must be referable", idxcnt
+ 1 + argoffset
);
3295 tree t
, forxx
, ptr
, lower
, upper
;
3297 t
= build_component_ref (array_ref
, get_identifier ("__t"));
3298 forxx
= build_component_ref (t
, get_identifier ("__loccharrange"));
3299 ptr
= build_component_ref (forxx
, get_identifier ("ptr"));
3300 lower
= build_component_ref (forxx
, get_identifier ("lower"));
3301 upper
= build_component_ref (forxx
, get_identifier ("upper"));
3302 expand_assignment (ptr
, item_addr
, 0, 0);
3303 expand_assignment (lower
, range_low
, 0, 0);
3304 expand_assignment (upper
, range_high
, 0, 0);
3307 enumname
= "__IO_CharRangeLoc";
3311 to_assign
= item_addr
;
3312 fieldname
= "__locchar";
3313 enumname
= "__IO_CharLoc";
3319 enumname
= "__IO_CharVal";
3320 fieldname
= "__valchar";
3327 t
= build_component_ref (array_ref
, get_identifier ("__t"));
3328 forxx
= build_component_ref (t
, get_identifier (fieldname
));
3329 expand_assignment (forxx
, to_assign
, 0, 0);
3332 else if (TREE_CODE (item_type
) == BOOLEAN_TYPE
)
3334 tree to_assign
= NULL_TREE
;
3336 if (do_read
&& readonly
)
3338 error ("argument %d is READonly", idxcnt
+ 1 + argoffset
);
3345 error ("argument %d must be referable", idxcnt
+ 1 + argoffset
);
3350 tree t
, forxx
, ptr
, lower
, upper
;
3352 t
= build_component_ref (array_ref
, get_identifier ("__t"));
3353 forxx
= build_component_ref (t
, get_identifier ("__locboolrange"));
3354 ptr
= build_component_ref (forxx
, get_identifier ("ptr"));
3355 lower
= build_component_ref (forxx
, get_identifier ("lower"));
3356 upper
= build_component_ref (forxx
, get_identifier ("upper"));
3357 expand_assignment (ptr
, item_addr
, 0, 0);
3358 expand_assignment (lower
, range_low
, 0, 0);
3359 expand_assignment (upper
, range_high
, 0, 0);
3362 enumname
= "__IO_BoolRangeLoc";
3366 to_assign
= item_addr
;
3367 fieldname
= "__locbool";
3368 enumname
= "__IO_BoolLoc";
3374 enumname
= "__IO_BoolVal";
3375 fieldname
= "__valbool";
3381 t
= build_component_ref (array_ref
, get_identifier ("__t"));
3382 forxx
= build_component_ref (t
, get_identifier (fieldname
));
3383 expand_assignment (forxx
, to_assign
, 0, 0);
3386 else if (TREE_CODE (item_type
) == ENUMERAL_TYPE
)
3388 /* process an enum */
3390 tree context_of_type
;
3393 /* determine the context of the type.
3394 if TYPE_NAME (item_type) == NULL_TREE
3395 if TREE_CODE (item) == INTEGER_CST
3396 context = NULL_TREE -- this is wrong but should work for now
3398 context = DECL_CONTEXT (item)
3400 context = DECL_CONTEXT (TYPE_NAME (item_type)) */
3402 if (TYPE_NAME (item_type
) == NULL_TREE
)
3404 if (TREE_CODE (item
) == INTEGER_CST
)
3405 context_of_type
= NULL_TREE
;
3407 context_of_type
= DECL_CONTEXT (item
);
3410 context_of_type
= DECL_CONTEXT (TYPE_NAME (item_type
));
3412 table_name
= add_enum_to_list (item_type
, context_of_type
);
3413 t
= build_component_ref (array_ref
, get_identifier ("__t"));
3415 if (do_read
&& readonly
)
3417 error ("argument %d is READonly", idxcnt
+ 1 + argoffset
);
3424 error ("argument %d must be referable", idxcnt
+ 1 + argoffset
);
3429 tree forxx
, ptr
, len
, nametable
, lower
, upper
;
3431 forxx
= build_component_ref (t
, get_identifier ("__locsetrange"));
3432 ptr
= build_component_ref (forxx
, get_identifier ("ptr"));
3433 len
= build_component_ref (forxx
, get_identifier ("length"));
3434 nametable
= build_component_ref (forxx
, get_identifier ("name_table"));
3435 lower
= build_component_ref (forxx
, get_identifier ("lower"));
3436 upper
= build_component_ref (forxx
, get_identifier ("upper"));
3437 expand_assignment (ptr
, item_addr
, 0, 0);
3438 expand_assignment (len
, size_in_bytes (item_type
), 0, 0);
3439 expand_assignment (nametable
, table_name
, 0, 0);
3440 expand_assignment (lower
, range_low
, 0, 0);
3441 expand_assignment (upper
, range_high
, 0, 0);
3443 enumname
= "__IO_SetRangeLoc";
3447 tree forxx
, ptr
, len
, nametable
;
3449 forxx
= build_component_ref (t
, get_identifier ("__locset"));
3450 ptr
= build_component_ref (forxx
, get_identifier ("ptr"));
3451 len
= build_component_ref (forxx
, get_identifier ("length"));
3452 nametable
= build_component_ref (forxx
, get_identifier ("name_table"));
3453 expand_assignment (ptr
, item_addr
, 0, 0);
3454 expand_assignment (len
, size_in_bytes (item_type
), 0, 0);
3455 expand_assignment (nametable
, table_name
, 0, 0);
3457 enumname
= "__IO_SetLoc";
3462 tree forxx
, value
, nametable
;
3464 forxx
= build_component_ref (t
, get_identifier ("__valset"));
3465 value
= build_component_ref (forxx
, get_identifier ("value"));
3466 nametable
= build_component_ref (forxx
, get_identifier ("name_table"));
3467 expand_assignment (value
, item
, 0, 0);
3468 expand_assignment (nametable
, table_name
, 0, 0);
3470 enumname
= "__IO_SetVal";
3473 else if (chill_varying_string_type_p (item_type
))
3475 /* varying char string */
3476 tree t
= build_component_ref (array_ref
, get_identifier ("__t"));
3477 tree forxx
= build_component_ref (t
, get_identifier ("__loccharstring"));
3478 tree string
= build_component_ref (forxx
, get_identifier ("string"));
3479 tree length
= build_component_ref (forxx
, get_identifier ("string_length"));
3481 if (do_read
&& readonly
)
3483 error ("argument %d is READonly", idxcnt
+ 1 + argoffset
);
3488 /* in this read case the argument must be referable */
3491 error ("argument %d must be referable", idxcnt
+ 1 + argoffset
);
3495 else if (! referable
)
3497 /* in the write case we create a temporary if not referable */
3499 tree loc
= build_decl (VAR_DECL
,
3500 get_unique_identifier ("WRTEXTVS"),
3502 t
= assign_temp (item_type
, 0, 1, 0);
3504 expand_assignment (loc
, item
, 0, 0);
3505 item_addr
= force_addr_of (loc
);
3509 expand_assignment (string
, item_addr
, 0, 0);
3511 /* we must pass the maximum length of the varying */
3512 expand_assignment (length
,
3513 size_in_bytes (TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (item_type
)))),
3516 /* we pass the actual length of the string */
3517 expand_assignment (length
,
3518 build_component_ref (item
, var_length_id
),
3521 enumname
= "__IO_CharVaryingLoc";
3523 else if (CH_CHARS_TYPE_P (item_type
))
3525 /* fixed character string */
3527 tree t
= build_component_ref (array_ref
, get_identifier ("__t"));
3528 tree forxx
= build_component_ref (t
, get_identifier ("__loccharstring"));
3529 tree string
= build_component_ref (forxx
, get_identifier ("string"));
3530 tree length
= build_component_ref (forxx
, get_identifier ("string_length"));
3532 if (do_read
&& readonly
)
3534 error ("argument %d is READonly", idxcnt
+ 1 + argoffset
);
3539 /* in this read case the argument must be referable */
3540 if (! CH_REFERABLE (item
))
3542 error ("argument %d must be referable", idxcnt
+ 1 + argoffset
);
3546 item_addr
= force_addr_of (item
);
3547 the_size
= size_in_bytes (item_type
);
3548 enumname
= "__IO_CharStrLoc";
3552 if (! CH_REFERABLE (item
))
3554 /* in the write case we create a temporary if not referable */
3558 howmuchbytes
= int_size_in_bytes (item_type
);
3559 if (howmuchbytes
!= -1)
3562 tree loc
= build_decl (VAR_DECL
,
3563 get_unique_identifier ("WRTEXTVS"),
3565 t
= assign_temp (item_type
, 0, 1, 0);
3567 expand_assignment (loc
, item
, 0, 0);
3568 item_addr
= force_addr_of (loc
);
3569 the_size
= size_in_bytes (item_type
);
3570 enumname
= "__IO_CharStrLoc";
3574 tree type
, string
, exp
, loc
;
3576 if ((howmuchbytes
= intsize_of_charsexpr (item
)) == -1)
3578 error ("cannot process argument %d of WRITETEXT, unknown size",
3579 idxcnt
+ 1 + argoffset
);
3582 string
= build_string_type (char_type_node
,
3583 build_int_2 (howmuchbytes
, 0));
3584 type
= build_varying_struct (string
);
3585 loc
= build_decl (VAR_DECL
,
3586 get_unique_identifier ("WRTEXTCS"),
3588 t
= assign_temp (type
, 0, 1, 0);
3590 exp
= chill_convert_for_assignment (type
, item
, 0);
3591 expand_assignment (loc
, exp
, 0, 0);
3592 item_addr
= force_addr_of (loc
);
3593 the_size
= integer_zero_node
;
3594 enumname
= "__IO_CharVaryingLoc";
3599 item_addr
= force_addr_of (item
);
3600 the_size
= size_in_bytes (item_type
);
3601 enumname
= "__IO_CharStrLoc";
3605 expand_assignment (string
, item_addr
, 0, 0);
3606 expand_assignment (length
, size_in_bytes (item_type
), 0, 0);
3609 else if (CH_BOOLS_TYPE_P (item_type
))
3611 /* we have a bitstring */
3612 tree t
= build_component_ref (array_ref
, get_identifier ("__t"));
3613 tree forxx
= build_component_ref (t
, get_identifier ("__loccharstring"));
3614 tree string
= build_component_ref (forxx
, get_identifier ("string"));
3615 tree length
= build_component_ref (forxx
, get_identifier ("string_length"));
3617 if (do_read
&& readonly
)
3619 error ("argument %d is READonly", idxcnt
+ 1 + argoffset
);
3624 /* in this read case the argument must be referable */
3627 error ("argument %d must be referable", idxcnt
+ 1 + argoffset
);
3631 else if (! referable
)
3633 /* in the write case we create a temporary if not referable */
3634 tree loc
= build_decl (VAR_DECL
,
3635 get_unique_identifier ("WRTEXTVS"),
3637 DECL_RTL (loc
) = assign_temp (item_type
, 0, 1, 0);
3638 expand_assignment (loc
, item
, 0, 0);
3639 item_addr
= force_addr_of (loc
);
3642 expand_assignment (string
, item_addr
, 0, 0);
3643 expand_assignment (length
, build_chill_length (item
), 0, 0);
3645 enumname
= "__IO_BitStrLoc";
3647 else if (TREE_CODE (item_type
) == REAL_TYPE
)
3649 /* process a (long_)real */
3650 tree t
, forxx
, to_assign
;
3652 if (do_read
&& readonly
)
3654 error ("argument %d is READonly", idxcnt
+ 1 + argoffset
);
3657 if (do_read
&& ! referable
)
3659 error ("argument %d must be referable", idxcnt
+ 1 + argoffset
);
3663 if (lookup_name (ridpointers
[RID_FLOAT
]) == TYPE_NAME (item_type
))
3665 /* we have a real */
3668 enumname
= "__IO_RealLoc";
3669 fieldname
= "__locreal";
3670 to_assign
= item_addr
;
3674 enumname
= "__IO_RealVal";
3675 fieldname
= "__valreal";
3681 /* we have a long_real */
3684 enumname
= "__IO_LongRealLoc";
3685 fieldname
= "__loclongreal";
3686 to_assign
= item_addr
;
3690 enumname
= "__IO_LongRealVal";
3691 fieldname
= "__vallongreal";
3695 t
= build_component_ref (array_ref
, get_identifier ("__t"));
3696 forxx
= build_component_ref (t
, get_identifier (fieldname
));
3697 expand_assignment (forxx
, to_assign
, 0, 0);
3700 /* don't process them for now */
3701 else if (TREE_CODE (item_type
) == POINTER_TYPE
)
3703 /* we have a pointer */
3706 __t
= build_component_ref (array_ref
, get_identifier ("__t"));
3707 __forxx
= build_component_ref (__t
, get_identifier ("__forpointer"));
3708 expand_assignment (__forxx
, item
, 0, 0);
3709 enumname
= "_IO_Pointer";
3711 else if (item_type
== instance_type_node
)
3713 /* we have an INSTANCE */
3716 __t
= build_component_ref (array_ref
, get_identifier ("__t"));
3717 __forxx
= build_component_ref (__t
, get_identifier ("__forinstance"));
3718 expand_assignment (__forxx
, item
, 0, 0);
3719 enumname
= "_IO_Instance";
3724 /* datatype is not yet implemented, issue a warning */
3725 error ("cannot process mode of argument %d for %sTEXT.", idxcnt
+ 1 + argoffset
,
3726 do_read
? "READ" : "WRITE");
3727 enumname
= "__IO_UNUSED";
3730 /* do assignment of the enum */
3733 tree descr
= build_component_ref (array_ref
,
3734 get_identifier ("__descr"));
3735 expand_assignment (descr
,
3736 lookup_name (get_identifier (enumname
)), 0, 0);
3740 /* set up address and length of iolist */
3741 *iolist_addr
= build_chill_addr_expr (iolist
, (char *)0);
3742 *iolist_length
= build_int_2 (iolen
, 0);
3745 /* check the format string */
3759 #define isDEC(c) ( chartab[(c)] & DEC )
3760 #define isCVC(c) ( chartab[(c)] & CVC )
3761 #define isEDC(c) ( chartab[(c)] & EDC )
3762 #define isIOC(c) ( chartab[(c)] & IOC )
3764 #define isXXX(c,XXX) ( chartab[(c)] & XXX )
3767 short int chartab
[256] = {
3768 0, 0, 0, 0, 0, 0, 0, 0,
3769 0, SPC
, SPC
, SPC
, SPC
, SPC
, 0, 0,
3771 0, 0, 0, 0, 0, 0, 0, 0,
3772 0, 0, 0, 0, 0, 0, 0, 0,
3774 SPC
, IOC
, 0, 0, 0, 0, 0, 0,
3775 SCS
, SCS
, SCS
, SCS
+IOC
, SCS
, SCS
+IOC
, SCS
, SCS
+IOC
,
3776 BIN
+OCT
+DEC
+HEX
, BIN
+OCT
+DEC
+HEX
, OCT
+DEC
+HEX
, OCT
+DEC
+HEX
, OCT
+DEC
+HEX
,
3777 OCT
+DEC
+HEX
, OCT
+DEC
+HEX
, OCT
+DEC
+HEX
,
3778 DEC
+HEX
, DEC
+HEX
, SCS
, SCS
, SCS
+EDC
, SCS
+IOC
, SCS
+EDC
, IOC
,
3780 0, LET
+HEX
+BIL
, LET
+HEX
+BIL
+CVC
, LET
+HEX
+BIL
+CVC
, LET
+HEX
+BIL
, LET
+HEX
,
3782 LET
+BIL
+CVC
, LET
, LET
, LET
, LET
, LET
, LET
, LET
+CVC
,
3784 LET
, LET
, LET
, LET
, LET
+EDC
, LET
, LET
, LET
,
3785 LET
+EDC
, LET
, LET
, SCS
, 0, SCS
, 0, USC
,
3787 0, LET
+HEX
, LET
+HEX
, LET
+HEX
, LET
+HEX
, LET
+HEX
, LET
+HEX
, LET
,
3788 LET
, LET
, LET
, LET
, LET
, LET
, LET
, LET
,
3790 LET
, LET
, LET
, LET
, LET
, LET
, LET
, LET
,
3791 LET
, LET
, LET
, 0, 0, 0, 0, 0
3796 FormatText
, FirstPercent
, RepFact
, ConvClause
, EditClause
, ClauseEnd
,
3797 AfterWidth
, FractWidth
, FractWidthCont
, ExpoWidth
, ExpoWidthCont
,
3798 ClauseWidth
, CatchPadding
, LastPercent
3801 #define CONVERSIONCODES "CHOBF"
3804 DefaultConv
, HexConv
, OctalConv
, BinaryConv
, ScientConv
3806 static convcode_t convcode
;
3808 static tree check_exprlist
PARAMS ((convcode_t
, tree
, int,
3816 static unsigned long fractionwidth
;
3818 #define IOCODES "/+-?!="
3820 NextRecord
, NextPage
, CurrentLine
, Prompt
, Emit
, EndPage
3822 static iocode_t iocode
;
3824 #define EDITCODES "X<>T"
3826 SpaceSkip
, SkipLeft
, SkipRight
, Tabulation
3828 static editcode_t editcode
;
3830 static unsigned long clausewidth
;
3831 static Boolean leftadjust
;
3832 static Boolean overflowev
;
3833 static Boolean dynamicwid
;
3834 static Boolean paddingdef
;
3835 static char paddingchar
;
3836 static Boolean fractiondef
;
3837 static Boolean exponentdef
;
3838 static unsigned long exponentwidth
;
3839 static unsigned long repetition
;
3842 NormalEnd
, EndAtParen
, TextFailEnd
3845 static formatexit_t scanformcont
PARAMS ((char *, int, char **, int *,
3846 tree
, tree
*, int, int *));
3848 /* NOTE: varibale have to be set to False before calling check_format_string */
3849 static Boolean empty_printed
;
3851 static int formstroffset
;
3854 check_exprlist (code
, exprlist
, argnum
, repetition
)
3858 unsigned long repetition
;
3860 tree expr
, type
, result
= NULL_TREE
;
3862 while (repetition
--)
3864 if (exprlist
== NULL_TREE
)
3866 if (empty_printed
== False
)
3868 warning ("too few arguments for this format string");
3869 empty_printed
= True
;
3873 expr
= TREE_VALUE (exprlist
);
3874 result
= exprlist
= TREE_CHAIN (exprlist
);
3875 if (expr
== NULL_TREE
|| TREE_CODE (expr
) == ERROR_MARK
)
3877 type
= TREE_TYPE (expr
);
3878 if (type
== NULL_TREE
|| TREE_CODE (type
) == ERROR_MARK
)
3880 if (TREE_CODE (type
) == REFERENCE_TYPE
)
3881 type
= TREE_TYPE (type
);
3882 if (type
== NULL_TREE
|| TREE_CODE (type
) == ERROR_MARK
)
3888 /* %C, everything is allowed. Not know types are flaged later. */
3891 /* %F, must be a REAL */
3892 if (TREE_CODE (type
) != REAL_TYPE
)
3893 warning ("type of argument %d invalid for conversion code at offset %d",
3894 argnum
, formstroffset
);
3900 /* %H, %O, %B, and V as clause width */
3901 if (TREE_CODE (type
) != INTEGER_TYPE
)
3902 warning ("type of argument %d invalid for conversion code at offset %d",
3903 argnum
, formstroffset
);
3906 /* there is an invalid conversion code */
3914 scanformcont (fcs
, len
, fcsptr
, lenptr
, exprlist
, exprptr
,
3915 firstargnum
, nextargnum
)
3925 fcsstate_t state
= FormatText
;
3937 state
= FirstPercent
;
3940 after_first_percent
: ;
3951 *exprptr
= exprlist
;
3952 *nextargnum
= firstargnum
;
3958 repetition
= curr
- '0';
3964 test_for_control_codes
: ;
3968 convcode
= strchr (CONVERSIONCODES
, curr
) - CONVERSIONCODES
;
3974 fractiondef
= False
;
3975 /* fractionwidth = 0; default depends on mode ! */
3976 exponentdef
= False
;
3979 /* check the argument */
3980 exprlist
= check_exprlist (convcode
, exprlist
, firstargnum
, repetition
);
3987 editcode
= strchr (EDITCODES
, curr
) - EDITCODES
;
3989 clausewidth
= editcode
== Tabulation
? 0 : 1;
3995 iocode
= strchr (IOCODES
, curr
) - IOCODES
;
4000 unsigned long times
= repetition
;
4008 if (scanformcont (fcs
, len
, &cntfcs
, &cntlen
,
4009 exprlist
, &cntexprlist
,
4010 firstargnum
, &nextarg
) != EndAtParen
)
4012 warning ("unmatched open paren");
4015 exprlist
= cntexprlist
;
4021 exprlist
= cntexprlist
;
4022 firstargnum
= nextarg
;
4026 warning ("bad format specification character (offset %d)", formstroffset
);
4028 /* skip one argument */
4029 if (exprlist
!= NULL_TREE
)
4030 exprlist
= TREE_CHAIN (exprlist
);
4037 if (repetition
> (ULONG_MAX
- dig
)/10)
4039 warning ("repetition factor overflow (offset %d)", formstroffset
);
4042 repetition
= repetition
*10 + dig
;
4045 goto test_for_control_codes
;
4050 state
= ClauseWidth
;
4051 clausewidth
= curr
- '0';
4057 warning ("duplicate qualifier (offset %d)", formstroffset
);
4064 warning ("duplicate qualifier (offset %d)", formstroffset
);
4071 warning ("duplicate qualifier (offset %d)", formstroffset
);
4073 state
= CatchPadding
;
4077 test_for_variable_width
: ;
4082 exprlist
= check_exprlist (-1, exprlist
, firstargnum
, 1);
4086 goto test_for_fraction_width
;
4092 if (clausewidth
> (ULONG_MAX
- dig
)/10)
4093 warning ("clause width overflow (offset %d)", formstroffset
);
4095 clausewidth
= clausewidth
*10 + dig
;
4100 test_for_fraction_width
: ;
4104 if (convcode
!= DefaultConv
&& convcode
!= ScientConv
)
4106 warning ("no fraction (offset %d)", formstroffset
);
4114 goto test_for_exponent_width
;
4119 state
= FractWidthCont
;
4120 fractionwidth
= curr
- '0';
4124 warning ("no fraction width (offset %d)", formstroffset
);
4126 case FractWidthCont
:
4130 if (fractionwidth
> (ULONG_MAX
- dig
)/10)
4131 warning ("fraction width overflow (offset %d)", formstroffset
);
4133 fractionwidth
= fractionwidth
*10 + dig
;
4137 test_for_exponent_width
: ;
4140 if (convcode
!= ScientConv
)
4142 warning ("no exponent (offset %d)", formstroffset
);
4150 goto test_for_final_percent
;
4155 state
= ExpoWidthCont
;
4156 exponentwidth
= curr
- '0';
4160 warning ("no exponent width (offset %d)", formstroffset
);
4166 if (exponentwidth
> (ULONG_MAX
- dig
)/10)
4167 warning ("exponent width overflow (offset %d)", formstroffset
);
4169 exponentwidth
= exponentwidth
*10 + dig
;
4174 test_for_final_percent
: ;
4178 state
= LastPercent
;
4193 state
= ClauseWidth
;
4194 clausewidth
= curr
- '0';
4197 goto test_for_variable_width
;
4205 goto after_first_percent
;
4208 error ("internal error in check_format_string");
4221 warning ("bad format specification character (offset %d)", formstroffset
);
4224 warning ("no padding character (offset %d)", formstroffset
);
4231 *exprptr
= exprlist
;
4232 *nextargnum
= firstargnum
;
4236 check_format_string (format_str
, exprlist
, firstargnum
)
4245 if (TREE_CODE (format_str
) != STRING_CST
)
4246 /* do nothing if we don't have a string constant */
4250 scanformcont (TREE_STRING_POINTER (format_str
),
4251 TREE_STRING_LENGTH (format_str
), &x
, &y
,
4255 /* too may arguments for format string */
4256 warning ("too many arguments for this format string");
4263 if (TREE_CODE (expr
) == INDIRECT_REF
)
4265 tree x
= TREE_OPERAND (expr
, 0);
4266 tree y
= TREE_OPERAND (x
, 0);
4267 return int_size_in_bytes (TREE_TYPE (y
));
4269 else if (TREE_CODE (expr
) == CONCAT_EXPR
)
4270 return intsize_of_charsexpr (expr
);
4272 return int_size_in_bytes (TREE_TYPE (expr
));
4276 intsize_of_charsexpr (expr
)
4279 int op0size
, op1size
;
4281 if (TREE_CODE (expr
) != CONCAT_EXPR
)
4284 /* find maximum length of CONCAT_EXPR, this is the worst case */
4285 op0size
= get_max_size (TREE_OPERAND (expr
, 0));
4286 op1size
= get_max_size (TREE_OPERAND (expr
, 1));
4287 if (op0size
== -1 || op1size
== -1)
4289 return op0size
+ op1size
;
4293 build_chill_writetext (text_arg
, exprlist
)
4294 tree text_arg
, exprlist
;
4296 tree iolist_addr
= null_pointer_node
;
4297 tree iolist_length
= integer_zero_node
;
4304 tree filename
, linenumber
;
4305 tree format_str
= NULL_TREE
, indexexpr
= NULL_TREE
;
4306 rtx iolist_rtx
= NULL_RTX
;
4309 /* make some checks */
4310 if (text_arg
== NULL_TREE
|| TREE_CODE (text_arg
) == ERROR_MARK
)
4311 return error_mark_node
;
4313 if (exprlist
!= NULL_TREE
)
4315 if (TREE_CODE (exprlist
) != TREE_LIST
)
4316 return error_mark_node
;
4319 /* check the text argument */
4320 if (chill_varying_string_type_p (TREE_TYPE (text_arg
)))
4322 /* build outstr-addr and outstr-length assuming that this is a CHAR (n) VARYING */
4323 outstr_addr
= force_addr_of (text_arg
);
4324 outstr_length
= size_in_bytes (CH_VARYING_ARRAY_TYPE (TREE_TYPE (text_arg
)));
4325 outfunction
= lookup_name (get_identifier ("__writetext_s"));
4326 format_str
= TREE_VALUE (exprlist
);
4327 exprlist
= TREE_CHAIN (exprlist
);
4329 else if (CH_IS_TEXT_MODE (TREE_TYPE (text_arg
)))
4331 /* we have a text mode */
4334 if (! check_text (text_arg
, 1, "WRITETEXT"))
4335 return error_mark_node
;
4336 indexmode
= text_indexmode (TREE_TYPE (text_arg
));
4337 if (indexmode
== void_type_node
)
4340 format_str
= TREE_VALUE (exprlist
);
4341 exprlist
= TREE_CHAIN (exprlist
);
4345 /* we have an index. there must be an index argument before format string */
4346 indexexpr
= TREE_VALUE (exprlist
);
4347 exprlist
= TREE_CHAIN (exprlist
);
4348 if (! CH_COMPATIBLE (indexexpr
, indexmode
))
4350 if (chill_varying_string_type_p (TREE_TYPE (indexexpr
)) ||
4351 (CH_CHARS_TYPE_P (TREE_TYPE (indexexpr
)) ||
4352 (flag_old_strings
&& TREE_CODE (indexexpr
) == INTEGER_CST
&&
4353 TREE_CODE (TREE_TYPE (indexexpr
)) == CHAR_TYPE
)))
4354 error ("missing index expression");
4356 error ("incompatible index mode");
4357 return error_mark_node
;
4359 if (exprlist
== NULL_TREE
)
4361 error ("Too few arguments in call to `writetext'");
4362 return error_mark_node
;
4364 format_str
= TREE_VALUE (exprlist
);
4365 exprlist
= TREE_CHAIN (exprlist
);
4368 outstr_addr
= force_addr_of (text_arg
);
4369 outstr_length
= convert (integer_type_node
, indexexpr
);
4370 outfunction
= lookup_name (get_identifier ("__writetext_f"));
4374 error ("argument 1 for WRITETEXT must be a TEXT or CHARS(n) VARYING location");
4375 return error_mark_node
;
4378 /* check the format string */
4379 fstrtype
= TREE_TYPE (format_str
);
4380 if (CH_CHARS_TYPE_P (fstrtype
) ||
4381 (flag_old_strings
&& TREE_CODE (format_str
) == INTEGER_CST
&&
4382 TREE_CODE (fstrtype
) == CHAR_TYPE
))
4384 /* we have a character string */
4385 fstr_addr
= force_addr_of (format_str
);
4386 fstr_length
= size_in_bytes (fstrtype
);
4388 else if (chill_varying_string_type_p (TREE_TYPE (format_str
)))
4390 /* we have a varying char string */
4392 = force_addr_of (build_component_ref (format_str
, var_data_id
));
4393 fstr_length
= build_component_ref (format_str
, var_length_id
);
4397 error ("`format string' for WRITETEXT must be a CHARACTER string");
4398 return error_mark_node
;
4401 empty_printed
= False
;
4402 check_format_string (format_str
, exprlist
, argoffset
+ 3);
4403 process_io_list (exprlist
, &iolist_addr
, &iolist_length
, &iolist_rtx
, 0, argoffset
);
4405 /* tree to call the function */
4407 filename
= force_addr_of (get_chill_filename ());
4408 linenumber
= get_chill_linenumber ();
4411 build_chill_function_call (outfunction
,
4412 tree_cons (NULL_TREE
, outstr_addr
,
4413 tree_cons (NULL_TREE
, outstr_length
,
4414 tree_cons (NULL_TREE
, fstr_addr
,
4415 tree_cons (NULL_TREE
, fstr_length
,
4416 tree_cons (NULL_TREE
, iolist_addr
,
4417 tree_cons (NULL_TREE
, iolist_length
,
4418 tree_cons (NULL_TREE
, filename
,
4419 tree_cons (NULL_TREE
, linenumber
,
4420 NULL_TREE
))))))))));
4422 /* get rid of the iolist variable, if we have one */
4423 if (iolist_rtx
!= NULL_RTX
)
4431 /* return something the rest of the machinery can work with,
4433 return build1 (CONVERT_EXPR
, void_type_node
, integer_zero_node
);
4437 build_chill_readtext (text_arg
, exprlist
)
4438 tree text_arg
, exprlist
;
4440 tree instr_addr
, instr_length
, infunction
;
4441 tree fstr_addr
, fstr_length
, fstrtype
;
4442 tree iolist_addr
= null_pointer_node
;
4443 tree iolist_length
= integer_zero_node
;
4444 tree filename
, linenumber
;
4445 tree format_str
= NULL_TREE
, indexexpr
= NULL_TREE
;
4446 rtx iolist_rtx
= NULL_RTX
;
4449 /* make some checks */
4450 if (text_arg
== NULL_TREE
|| TREE_CODE (text_arg
) == ERROR_MARK
)
4451 return error_mark_node
;
4453 if (exprlist
!= NULL_TREE
)
4455 if (TREE_CODE (exprlist
) != TREE_LIST
)
4456 return error_mark_node
;
4459 /* check the text argument */
4460 if (CH_CHARS_TYPE_P (TREE_TYPE (text_arg
)))
4462 instr_addr
= force_addr_of (text_arg
);
4463 instr_length
= size_in_bytes (TREE_TYPE (text_arg
));
4464 infunction
= lookup_name (get_identifier ("__readtext_s"));
4465 format_str
= TREE_VALUE (exprlist
);
4466 exprlist
= TREE_CHAIN (exprlist
);
4468 else if (chill_varying_string_type_p (TREE_TYPE (text_arg
)))
4471 = force_addr_of (build_component_ref (text_arg
, var_data_id
));
4472 instr_length
= build_component_ref (text_arg
, var_length_id
);
4473 infunction
= lookup_name (get_identifier ("__readtext_s"));
4474 format_str
= TREE_VALUE (exprlist
);
4475 exprlist
= TREE_CHAIN (exprlist
);
4477 else if (CH_IS_TEXT_MODE (TREE_TYPE (text_arg
)))
4479 /* we have a text mode */
4482 if (! check_text (text_arg
, 1, "READTEXT"))
4483 return error_mark_node
;
4484 indexmode
= text_indexmode (TREE_TYPE (text_arg
));
4485 if (indexmode
== void_type_node
)
4488 format_str
= TREE_VALUE (exprlist
);
4489 exprlist
= TREE_CHAIN (exprlist
);
4493 /* we have an index. there must be an index argument before format string */
4494 indexexpr
= TREE_VALUE (exprlist
);
4495 exprlist
= TREE_CHAIN (exprlist
);
4496 if (! CH_COMPATIBLE (indexexpr
, indexmode
))
4498 if (chill_varying_string_type_p (TREE_TYPE (indexexpr
)) ||
4499 (CH_CHARS_TYPE_P (TREE_TYPE (indexexpr
)) ||
4500 (flag_old_strings
&& TREE_CODE (indexexpr
) == INTEGER_CST
&&
4501 TREE_CODE (TREE_TYPE (indexexpr
)) == CHAR_TYPE
)))
4502 error ("missing index expression");
4504 error ("incompatible index mode");
4505 return error_mark_node
;
4507 if (exprlist
== NULL_TREE
)
4509 error ("Too few arguments in call to `readtext'");
4510 return error_mark_node
;
4512 format_str
= TREE_VALUE (exprlist
);
4513 exprlist
= TREE_CHAIN (exprlist
);
4516 instr_addr
= force_addr_of (text_arg
);
4517 instr_length
= convert (integer_type_node
, indexexpr
);
4518 infunction
= lookup_name (get_identifier ("__readtext_f"));
4522 error ("argument 1 for READTEXT must be a TEXT location or CHARS(n) [ VARYING ] expression");
4523 return error_mark_node
;
4526 /* check the format string */
4527 fstrtype
= TREE_TYPE (format_str
);
4528 if (CH_CHARS_TYPE_P (fstrtype
))
4530 /* we have a character string */
4531 fstr_addr
= force_addr_of (format_str
);
4532 fstr_length
= size_in_bytes (fstrtype
);
4534 else if (chill_varying_string_type_p (fstrtype
))
4536 /* we have a CHARS(n) VARYING */
4538 = force_addr_of (build_component_ref (format_str
, var_data_id
));
4539 fstr_length
= build_component_ref (format_str
, var_length_id
);
4543 error ("`format string' for READTEXT must be a CHARACTER string");
4544 return error_mark_node
;
4547 empty_printed
= False
;
4548 check_format_string (format_str
, exprlist
, argoffset
+ 3);
4549 process_io_list (exprlist
, &iolist_addr
, &iolist_length
, &iolist_rtx
, 1, argoffset
);
4551 /* build the function call */
4552 filename
= force_addr_of (get_chill_filename ());
4553 linenumber
= get_chill_linenumber ();
4555 build_chill_function_call (infunction
,
4556 tree_cons (NULL_TREE
, instr_addr
,
4557 tree_cons (NULL_TREE
, instr_length
,
4558 tree_cons (NULL_TREE
, fstr_addr
,
4559 tree_cons (NULL_TREE
, fstr_length
,
4560 tree_cons (NULL_TREE
, iolist_addr
,
4561 tree_cons (NULL_TREE
, iolist_length
,
4562 tree_cons (NULL_TREE
, filename
,
4563 tree_cons (NULL_TREE
, linenumber
,
4564 NULL_TREE
))))))))));
4566 /* get rid of the iolist variable, if we have one */
4567 if (iolist_rtx
!= NULL_RTX
)
4575 /* return something the rest of the machinery can work with,
4577 return build1 (CONVERT_EXPR
, void_type_node
, integer_zero_node
);
4580 /* this function build all neccesary enum-tables used for
4581 WRITETEXT or READTEXT of an enum */
4583 void build_enum_tables ()
4585 SAVE_ENUM_NAMES
*names
;
4588 /* We temporarily reset the maximum_field_alignment to zero so the
4589 compiler's init data structures can be compatible with the
4590 run-time system, even when we're compiling with -fpack. */
4591 unsigned int save_maximum_field_alignment
;
4596 save_maximum_field_alignment
= maximum_field_alignment
;
4597 maximum_field_alignment
= 0;
4599 /* output all names */
4600 names
= used_enum_names
;
4602 while (names
!= (SAVE_ENUM_NAMES
*)0)
4604 tree var
= get_unique_identifier ("ENUMNAME");
4607 type
= build_string_type (char_type_node
,
4608 build_int_2 (IDENTIFIER_LENGTH (names
->name
) + 1, 0));
4609 names
->decl
= decl_temp1 (var
, type
, 1,
4610 build_chill_string (IDENTIFIER_LENGTH (names
->name
) + 1,
4611 IDENTIFIER_POINTER (names
->name
)),
4613 names
= names
->forward
;
4616 /* output the tables and pointers to tables */
4618 while (wrk
!= (SAVE_ENUMS
*)0)
4620 tree varptr
= wrk
->ptrdecl
;
4621 tree table_addr
= null_pointer_node
;
4622 tree init
= NULL_TREE
, one_entry
;
4623 tree table
, idxlist
, tabletype
, addr
;
4624 SAVE_ENUM_VALUES
*vals
;
4628 for (i
= 0; i
< wrk
->num_vals
; i
++)
4630 tree decl
= vals
->name
->decl
;
4631 addr
= build1 (ADDR_EXPR
,
4632 build_pointer_type (char_type_node
),
4634 TREE_CONSTANT (addr
) = 1;
4635 one_entry
= tree_cons (NULL_TREE
, build_int_2 (vals
->val
, 0),
4636 tree_cons (NULL_TREE
, addr
, NULL_TREE
));
4637 one_entry
= build_nt (CONSTRUCTOR
, NULL_TREE
, one_entry
);
4638 init
= tree_cons (NULL_TREE
, one_entry
, init
);
4642 /* add the terminator (name = null_pointer_node) to constructor */
4643 one_entry
= tree_cons (NULL_TREE
, integer_zero_node
,
4644 tree_cons (NULL_TREE
, null_pointer_node
, NULL_TREE
));
4645 one_entry
= build_nt (CONSTRUCTOR
, NULL_TREE
, one_entry
);
4646 init
= tree_cons (NULL_TREE
, one_entry
, init
);
4647 init
= nreverse (init
);
4648 init
= build_nt (CONSTRUCTOR
, NULL_TREE
, init
);
4649 TREE_CONSTANT (init
) = 1;
4651 /* generate table */
4652 idxlist
= build_tree_list (NULL_TREE
,
4653 build_chill_range_type (NULL_TREE
,
4655 build_int_2 (wrk
->num_vals
, 0)));
4656 tabletype
= build_chill_array_type (TREE_TYPE (enum_table_type
),
4657 idxlist
, 0, NULL_TREE
);
4658 table
= decl_temp1 (get_unique_identifier ("ENUMTAB"), tabletype
,
4660 table_addr
= build1 (ADDR_EXPR
,
4661 build_pointer_type (TREE_TYPE (enum_table_type
)),
4663 TREE_CONSTANT (table_addr
) = 1;
4665 /* generate pointer to table */
4666 decl_temp1 (DECL_NAME (varptr
), TREE_TYPE (table_addr
),
4667 1, table_addr
, 0, 0);
4669 /* free that stuff */
4670 saveptr
= wrk
->forward
;
4679 /* free all the names */
4680 names
= used_enum_names
;
4681 while (names
!= (SAVE_ENUM_NAMES
*)0)
4683 saveptr
= names
->forward
;
4688 used_enums
= (SAVE_ENUMS
*)0;
4689 used_enum_names
= (SAVE_ENUM_NAMES
*)0;
4690 maximum_field_alignment
= save_maximum_field_alignment
;