?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
* c-decl.c (grokdeclarator): Use ISO word.
[official-gcc.git] / gcc / ch / inout.c
blobd83f1bd8501bed91fe9a0bee925bdf6abbf4faf2
1 /* Implement I/O-related actions for CHILL.
2 Copyright (C) 1992, 1993, 1994, 1998, 1999, 2000
3 Free Software Foundation, Inc.
4
5 This file is part of GNU CC.
6
7 GNU CC is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 2, or (at your option)
10 any later version.
11
12 GNU CC is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
16
17 You should have received a copy of the GNU General Public License
18 along with GNU CC; see the file COPYING. If not, write to
19 the Free Software Foundation, 59 Temple Place - Suite 330,
20 Boston, MA 02111-1307, USA. */
21
22 #include "config.h"
23 #include "system.h"
24 #include "tree.h"
25 #include "ch-tree.h"
26 #include "rtl.h"
27 #include "lex.h"
28 #include "flags.h"
29 #include "input.h"
30 #include "assert.h"
31 #include "toplev.h"
32
33 /* set non-zero if input text is forced to lowercase */
34 extern int ignore_case;
35
36 /* set non-zero if special words are to be entered in uppercase */
37 extern int special_UC;
38
39 static int intsize_of_charsexpr PARAMS ((tree));
40 static tree add_enum_to_list PARAMS ((tree, tree));
41 static void build_chill_io_list_type PARAMS ((void));
42 static void build_io_types PARAMS ((void));
43 static void declare_predefined_file PARAMS ((const char *, const char *));
44 static tree build_access_part PARAMS ((void));
45 static tree textlocation_mode PARAMS ((tree));
46 static int check_assoc PARAMS ((tree, int, const char *));
47 static tree assoc_call PARAMS ((tree, tree, const char *));
48 static int check_transfer PARAMS ((tree, int, const char *));
49 static int connect_process_optionals PARAMS ((tree, tree *, tree *, tree));
50 static tree connect_text PARAMS ((tree, tree, tree, tree));
51 static tree connect_access PARAMS ((tree, tree, tree, tree));
52 static int check_access PARAMS ((tree, int, const char *));
53 static int check_text PARAMS ((tree, int, const char *));
54 static tree get_final_type_and_range PARAMS ((tree, tree *, tree *));
55 static void process_io_list PARAMS ((tree, tree *, tree *, rtx *,
56 int, int));
57 static void check_format_string PARAMS ((tree, tree, int));
58 static int get_max_size PARAMS ((tree));
59
60 /* association mode */
61 tree association_type_node;
62 /* initialzier for association mode */
63 tree association_init_value;
64
65 /* NOTE: should be same as in runtime/chillrt0.c */
66 #define STDIO_TEXT_LENGTH 1024
67 /* mode of stdout, stdin, stderr*/
68 static tree stdio_type_node;
69
70 /* usage- and where modes */
71 tree usage_type_node;
72 tree where_type_node;
73
74 /* we have to distinguish between io-list-type for WRITETEXT
75 and for READTEXT. WRITETEXT does not process ranges and
76 READTEXT must get pointers to the variables.
77 */
78 /* variable to hold the type of the io_list */
79 static tree chill_io_list_type = NULL_TREE;
80
81 /* the type for the enum tables */
82 static tree enum_table_type = NULL_TREE;
83
84 /* structure to save enums for later use in compilation */
85 typedef struct save_enum_names
86 {
87 struct save_enum_names *forward;
88 tree name;
89 tree decl;
90 } SAVE_ENUM_NAMES;
91
92 static SAVE_ENUM_NAMES *used_enum_names = (SAVE_ENUM_NAMES *)0;
93
94 typedef struct save_enum_values
95 {
96 long val;
97 struct save_enum_names *name;
98 } SAVE_ENUM_VALUES;
99
100 typedef struct save_enums
101 {
102 struct save_enums *forward;
103 tree context;
104 tree type;
105 tree ptrdecl;
106 long num_vals;
107 struct save_enum_values *vals;
108 } SAVE_ENUMS;
109
110 static SAVE_ENUMS *used_enums = (SAVE_ENUMS *)0;
111
112 \f
113 /* Function collects all enums are necessary to collect, makes a copy of
114 the value and returns a VAR_DECL external to current function describing
115 the pointer to a name table, which will be generated at the end of
116 compilation
117 */
118
119 static tree add_enum_to_list (type, context)
120 tree type;
121 tree context;
122 {
123 tree tmp;
124 SAVE_ENUMS *wrk = used_enums;
125 SAVE_ENUM_VALUES *vals;
126 SAVE_ENUM_NAMES *names;
127
128 while (wrk != (SAVE_ENUMS *)0)
129 {
130 /* search for this enum already in use */
131 if (wrk->context == context && wrk->type == type)
132 {
133 /* yes, found. look if the ptrdecl is valid in this scope */
134 tree var = DECL_NAME (wrk->ptrdecl);
135 tree decl = lookup_name (var);
136
137 if (decl == NULL_TREE)
138 {
139 /* no, not valid in this context, declare it */
140 decl = decl_temp1 (var, build_pointer_type (TREE_TYPE (enum_table_type)),
141 0, NULL_TREE, 1, 0);
142 }
143 return decl;
144 }
145
146 /* next one */
147 wrk = wrk->forward;
148 }
149
150 /* not yet found -- generate an entry */
151 wrk = (SAVE_ENUMS *)xmalloc (sizeof (SAVE_ENUMS));
152 wrk->forward = used_enums;
153 used_enums = wrk;
154
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)),
158 0, NULL_TREE, 1, 0);
159
160 /* save information for later use */
161 wrk->context = context;
162 wrk->type = type;
163
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);
168 wrk->vals = vals;
169
170 while (tmp != NULL_TREE)
171 {
172 /* search if name is already in use */
173 names = used_enum_names;
174 while (names != (SAVE_ENUM_NAMES *)0)
175 {
176 if (names->name == TREE_PURPOSE (tmp))
177 break;
178 names = names->forward;
179 }
180 if (names == (SAVE_ENUM_NAMES *)0)
181 {
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);
188 }
189 vals->name = names;
190 vals->val = TREE_INT_CST_LOW (TREE_VALUE (tmp));
191
192 /* next entry in enum */
193 vals++;
194 tmp = TREE_CHAIN (tmp);
195 }
196
197 /* return the generated decl */
198 return wrk->ptrdecl;
199 }
200
201 \f
202 static void
203 build_chill_io_list_type ()
204 {
205 tree list = NULL_TREE;
206 tree result, enum1, listbase;
207 tree io_descriptor;
208 tree decl1, decl2;
209 tree forcharstring, forset_W, forset_R, forboolrange;
210
211 tree forintrange, intunion, forsetrange, forcharrange;
212 tree long_type, ulong_type, union_type;
213
214 long_type = long_integer_type_node;
215 ulong_type = long_unsigned_type_node;
216
217 if (chill_io_list_type != NULL_TREE)
218 /* already done */
219 return;
220
221 /* first build the enum for the desriptor */
222 enum1 = start_enum (NULL_TREE);
223 result = build_enumerator (get_identifier ("__IO_UNUSED"),
224 NULL_TREE);
225 list = chainon (result, list);
226
227 result = build_enumerator (get_identifier ("__IO_ByteVal"),
228 NULL_TREE);
229 list = chainon (result, list);
230
231 result = build_enumerator (get_identifier ("__IO_UByteVal"),
232 NULL_TREE);
233 list = chainon (result, list);
234
235 result = build_enumerator (get_identifier ("__IO_IntVal"),
236 NULL_TREE);
237 list = chainon (result, list);
238
239 result = build_enumerator (get_identifier ("__IO_UIntVal"),
240 NULL_TREE);
241 list = chainon (result, list);
242
243 result = build_enumerator (get_identifier ("__IO_LongVal"),
244 NULL_TREE);
245 list = chainon (result, list);
246
247 result = build_enumerator (get_identifier ("__IO_ULongVal"),
248 NULL_TREE);
249 list = chainon (result, list);
250
251 result = build_enumerator (get_identifier ("__IO_ByteLoc"),
252 NULL_TREE);
253 list = chainon (result, list);
254
255 result = build_enumerator (get_identifier ("__IO_UByteLoc"),
256 NULL_TREE);
257 list = chainon (result, list);
258
259 result = build_enumerator (get_identifier ("__IO_IntLoc"),
260 NULL_TREE);
261 list = chainon (result, list);
262
263 result = build_enumerator (get_identifier ("__IO_UIntLoc"),
264 NULL_TREE);
265 list = chainon (result, list);
266
267 result = build_enumerator (get_identifier ("__IO_LongLoc"),
268 NULL_TREE);
269 list = chainon (result, list);
270
271 result = build_enumerator (get_identifier ("__IO_ULongLoc"),
272 NULL_TREE);
273 list = chainon (result, list);
274
275 result = build_enumerator (get_identifier ("__IO_ByteRangeLoc"),
276 NULL_TREE);
277 list = chainon (result, list);
278
279 result = build_enumerator (get_identifier ("__IO_UByteRangeLoc"),
280 NULL_TREE);
281 list = chainon (result, list);
282
283 result = build_enumerator (get_identifier ("__IO_IntRangeLoc"),
284 NULL_TREE);
285 list = chainon (result, list);
286
287 result = build_enumerator (get_identifier ("__IO_UIntRangeLoc"),
288 NULL_TREE);
289 list = chainon (result, list);
290
291 result = build_enumerator (get_identifier ("__IO_LongRangeLoc"),
292 NULL_TREE);
293 list = chainon (result, list);
294
295 result = build_enumerator (get_identifier ("__IO_ULongRangeLoc"),
296 NULL_TREE);
297 list = chainon (result, list);
298
299 result = build_enumerator (get_identifier ("__IO_BoolVal"),
300 NULL_TREE);
301 list = chainon (result, list);
302
303 result = build_enumerator (get_identifier ("__IO_BoolLoc"),
304 NULL_TREE);
305 list = chainon (result, list);
306
307 result = build_enumerator (get_identifier ("__IO_BoolRangeLoc"),
308 NULL_TREE);
309 list = chainon (result, list);
310
311 result = build_enumerator (get_identifier ("__IO_SetVal"),
312 NULL_TREE);
313 list = chainon (result, list);
314
315 result = build_enumerator (get_identifier ("__IO_SetLoc"),
316 NULL_TREE);
317 list = chainon (result, list);
318
319 result = build_enumerator (get_identifier ("__IO_SetRangeLoc"),
320 NULL_TREE);
321 list = chainon (result, list);
322
323 result = build_enumerator (get_identifier ("__IO_CharVal"),
324 NULL_TREE);
325 list = chainon (result, list);
326
327 result = build_enumerator (get_identifier ("__IO_CharLoc"),
328 NULL_TREE);
329 list = chainon (result, list);
330
331 result = build_enumerator (get_identifier ("__IO_CharRangeLoc"),
332 NULL_TREE);
333 list = chainon (result, list);
334
335 result = build_enumerator (get_identifier ("__IO_CharStrLoc"),
336 NULL_TREE);
337 list = chainon (result, list);
338
339 result = build_enumerator (get_identifier ("__IO_CharVaryingLoc"),
340 NULL_TREE);
341 list = chainon (result, list);
342
343 result = build_enumerator (get_identifier ("__IO_BitStrLoc"),
344 NULL_TREE);
345 list = chainon (result, list);
346
347 result = build_enumerator (get_identifier ("__IO_RealVal"),
348 NULL_TREE);
349 list = chainon (result, list);
350
351 result = build_enumerator (get_identifier ("__IO_RealLoc"),
352 NULL_TREE);
353 list = chainon (result, list);
354
355 result = build_enumerator (get_identifier ("__IO_LongRealVal"),
356 NULL_TREE);
357 list = chainon (result, list);
358
359 result = build_enumerator (get_identifier ("__IO_LongRealLoc"),
360 NULL_TREE);
361 list = chainon (result, list);
362 #if 0
363 result = build_enumerator (get_identifier ("_IO_Pointer"),
364 NULL_TREE);
365 list = chainon (result, list);
366 #endif
367
368 result = finish_enum (enum1, list);
369 pushdecl (io_descriptor = build_decl (TYPE_DECL,
370 get_identifier ("__tmp_IO_enum"),
371 result));
372 /* prevent seizing/granting of the decl */
373 DECL_SOURCE_LINE (io_descriptor) = 0;
374 satisfy_decl (io_descriptor, 0);
375
376 /* build type for enum_tables */
377 decl1 = build_decl (FIELD_DECL, get_identifier ("value"),
378 long_type);
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"),
388 result));
389 DECL_SOURCE_LINE (enum_table_type) = 0;
390 satisfy_decl (enum_table_type, 0);
391
392 /* build type for writing a set mode */
393 decl1 = build_decl (FIELD_DECL, get_identifier ("value"),
394 long_type);
395 DECL_INITIAL (decl1) = NULL_TREE;
396 listbase = decl1;
397
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;
402 decl1 = decl2;
403 TREE_CHAIN (decl2) = NULL_TREE;
404
405 result = build_chill_struct_type (listbase);
406 pushdecl (forset_W = build_decl (TYPE_DECL,
407 get_identifier ("__tmp_WIO_set"),
408 result));
409 DECL_SOURCE_LINE (forset_W) = 0;
410 satisfy_decl (forset_W, 0);
411
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;
416 listbase = decl1;
417
418 decl2 = build_decl (FIELD_DECL, get_identifier ("lower"),
419 long_type);
420 DECL_INITIAL (decl2) = NULL_TREE;
421 TREE_CHAIN (decl1) = decl2;
422 decl1 = decl2;
423
424 decl2 = build_decl (FIELD_DECL, get_identifier ("upper"),
425 long_type);
426 DECL_INITIAL (decl2) = NULL_TREE;
427 TREE_CHAIN (decl1) = decl2;
428 TREE_CHAIN (decl2) = NULL_TREE;
429
430 result = build_chill_struct_type (listbase);
431 pushdecl (forcharrange = build_decl (TYPE_DECL,
432 get_identifier ("__tmp_IO_charrange"),
433 result));
434 DECL_SOURCE_LINE (forcharrange) = 0;
435 satisfy_decl (forcharrange, 0);
436
437 /* type for integer range */
438 decl1 = build_tree_list (NULL_TREE,
439 build_decl (FIELD_DECL,
440 get_identifier ("_slong"),
441 long_type));
442 listbase = decl1;
443
444 decl2 = build_tree_list (NULL_TREE,
445 build_decl (FIELD_DECL,
446 get_identifier ("_ulong"),
447 ulong_type));
448 TREE_CHAIN (decl1) = decl2;
449 TREE_CHAIN (decl2) = NULL_TREE;
450
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"),
456 result));
457 DECL_SOURCE_LINE (intunion) = 0;
458 satisfy_decl (intunion, 0);
459
460 decl1 = build_decl (FIELD_DECL,
461 get_identifier ("ptr"),
462 ptr_type_node);
463 listbase = decl1;
464
465 decl2 = build_decl (FIELD_DECL,
466 get_identifier ("lower"),
467 TREE_TYPE (intunion));
468 TREE_CHAIN (decl1) = decl2;
469 decl1 = decl2;
470
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;
476
477 result = build_chill_struct_type (listbase);
478 pushdecl (forintrange = build_decl (TYPE_DECL,
479 get_identifier ("__tmp_IO_intrange"),
480 result));
481 DECL_SOURCE_LINE (forintrange) = 0;
482 satisfy_decl (forintrange, 0);
483
484 /* build structure for bool range */
485 decl1 = build_decl (FIELD_DECL,
486 get_identifier ("ptr"),
487 ptr_type_node);
488 DECL_INITIAL (decl1) = NULL_TREE;
489 listbase = decl1;
490
491 decl2 = build_decl (FIELD_DECL,
492 get_identifier ("lower"),
493 ulong_type);
494 DECL_INITIAL (decl2) = NULL_TREE;
495 TREE_CHAIN (decl1) = decl2;
496 decl1 = decl2;
497
498 decl2 = build_decl (FIELD_DECL,
499 get_identifier ("upper"),
500 ulong_type);
501 DECL_INITIAL (decl2) = NULL_TREE;
502 TREE_CHAIN (decl1) = decl2;
503 TREE_CHAIN (decl2) = NULL_TREE;
504
505 result = build_chill_struct_type (listbase);
506 pushdecl (forboolrange = build_decl (TYPE_DECL,
507 get_identifier ("__tmp_RIO_boolrange"),
508 result));
509 DECL_SOURCE_LINE (forboolrange) = 0;
510 satisfy_decl (forboolrange, 0);
511
512 /* build type for reading a set */
513 decl1 = build_decl (FIELD_DECL, get_identifier ("ptr"),
514 ptr_type_node);
515 DECL_INITIAL (decl1) = NULL_TREE;
516 listbase = decl1;
517
518 decl2 = build_decl (FIELD_DECL, get_identifier ("length"),
519 long_type);
520 DECL_INITIAL (decl2) = NULL_TREE;
521 TREE_CHAIN (decl1) = decl2;
522 decl1 = decl2;
523
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;
529
530 result = build_chill_struct_type (listbase);
531 pushdecl (forset_R = build_decl (TYPE_DECL,
532 get_identifier ("__tmp_RIO_set"),
533 result));
534 DECL_SOURCE_LINE (forset_R) = 0;
535 satisfy_decl (forset_R, 0);
536
537 /* build type for setrange */
538 decl1 = build_decl (FIELD_DECL, get_identifier ("ptr"),
539 ptr_type_node);
540 DECL_INITIAL (decl1) = NULL_TREE;
541 listbase = decl1;
542
543 decl2 = build_decl (FIELD_DECL, get_identifier ("length"),
544 long_type);
545 DECL_INITIAL (decl2) = NULL_TREE;
546 TREE_CHAIN (decl1) = decl2;
547 decl1 = decl2;
548
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;
553 decl1 = decl2;
554
555 decl2 = build_decl (FIELD_DECL, get_identifier ("lower"),
556 long_type);
557 DECL_INITIAL (decl2) = NULL_TREE;
558 TREE_CHAIN (decl1) = decl2;
559 decl1 = decl2;
560
561 decl2 = build_decl (FIELD_DECL, get_identifier ("upper"),
562 long_type);
563 DECL_INITIAL (decl2) = NULL_TREE;
564 TREE_CHAIN (decl1) = decl2;
565 TREE_CHAIN (decl2) = NULL_TREE;
566
567 result = build_chill_struct_type (listbase);
568 pushdecl (forsetrange = build_decl (TYPE_DECL,
569 get_identifier ("__tmp_RIO_setrange"),
570 result));
571 DECL_SOURCE_LINE (forsetrange) = 0;
572 satisfy_decl (forsetrange, 0);
573
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;
579 listbase = decl1;
580
581 decl2 = build_decl (FIELD_DECL,
582 get_identifier ("string_length"),
583 ulong_type);
584 DECL_INITIAL (decl2) = NULL_TREE;
585 TREE_CHAIN (decl1) = decl2;
586 decl1 = decl2;
587 TREE_CHAIN (decl2) = NULL_TREE;
588
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);
594
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));
600 listbase = decl1;
601
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;
607 decl1 = decl2;
608
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;
614 decl1 = decl2;
615
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;
621 decl1 = decl2;
622
623 decl2 = build_tree_list (NULL_TREE,
624 build_decl (FIELD_DECL,
625 get_identifier ("__vallong"),
626 long_type));
627 TREE_CHAIN (decl1) = decl2;
628 decl1 = decl2;
629
630 decl2 = build_tree_list (NULL_TREE,
631 build_decl (FIELD_DECL,
632 get_identifier ("__valulong"),
633 ulong_type));
634 TREE_CHAIN (decl1) = decl2;
635 decl1 = decl2;
636
637 decl2 = build_tree_list (NULL_TREE,
638 build_decl (FIELD_DECL,
639 get_identifier ("__locint"),
640 ptr_type_node));
641 TREE_CHAIN (decl1) = decl2;
642 decl1 = decl2;
643
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;
649 decl1 = decl2;
650
651 decl2 = build_tree_list (NULL_TREE,
652 build_decl (FIELD_DECL,
653 get_identifier ("__valbool"),
654 boolean_type_node));
655 TREE_CHAIN (decl1) = decl2;
656 decl1 = decl2;
657
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;
663 decl1 = decl2;
664
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;
670 decl1 = decl2;
671
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;
677 decl1 = decl2;
678
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;
684 decl1 = decl2;
685
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;
691 decl1 = decl2;
692
693 decl2 = build_tree_list (NULL_TREE,
694 build_decl (FIELD_DECL,
695 get_identifier ("__valchar"),
696 char_type_node));
697 TREE_CHAIN (decl1) = decl2;
698 decl1 = decl2;
699
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;
705 decl1 = decl2;
706
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;
712 decl1 = decl2;
713
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;
719 decl1 = decl2;
720
721 decl2 = build_tree_list (NULL_TREE,
722 build_decl (FIELD_DECL,
723 get_identifier ("__valreal"),
724 float_type_node));
725 TREE_CHAIN (decl1) = decl2;
726 decl1 = decl2;
727
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;
733 decl1 = decl2;
734
735 decl2 = build_tree_list (NULL_TREE,
736 build_decl (FIELD_DECL,
737 get_identifier ("__vallongreal"),
738 double_type_node));
739 TREE_CHAIN (decl1) = decl2;
740 decl1 = decl2;
741
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;
747 decl1 = decl2;
748
749 #if 0
750 decl2 = build_tree_list (NULL_TREE,
751 build_decl (FIELD_DECL,
752 get_identifier ("__forpointer"),
753 ptr_type_node));
754 TREE_CHAIN (decl1) = decl2;
755 decl1 = decl2;
756 #endif
757
758 TREE_CHAIN (decl2) = NULL_TREE;
759
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"),
765 result));
766 DECL_SOURCE_LINE (union_type) = 0;
767 satisfy_decl (union_type, 0);
768
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;
773 listbase = decl1;
774
775 decl2 = build_decl (FIELD_DECL, get_identifier ("__descr"),
776 long_type);
777
778 TREE_CHAIN (decl1) = decl2;
779 TREE_CHAIN (decl2) = NULL_TREE;
780
781 result = build_chill_struct_type (listbase);
782 pushdecl (chill_io_list_type = build_decl (TYPE_DECL,
783 get_identifier ("__tmp_IO_list"),
784 result));
785 DECL_SOURCE_LINE (chill_io_list_type) = 0;
786 satisfy_decl (chill_io_list_type, 0);
787 }
788 \f
789 /* build the ASSOCIATION, ACCESS and TEXT mode types */
790 static void
791 build_io_types ()
792 {
793 tree listbase, decl1, decl2, result, association;
794 tree acc, txt, tloc;
795 tree enum1, tmp;
796
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;
802 decl1 = listbase;
803
804 decl2 = build_decl (FIELD_DECL,
805 get_identifier ("pathname"),
806 ptr_type_node);
807 DECL_INITIAL (decl2) = NULL_TREE;
808 TREE_CHAIN (decl1) = decl2;
809 decl1 = decl2;
810
811 decl2 = build_decl (FIELD_DECL,
812 get_identifier ("access"),
813 ptr_type_node);
814 DECL_INITIAL (decl2) = NULL_TREE;
815 TREE_CHAIN (decl1) = decl2;
816 decl1 = decl2;
817
818 decl2 = build_decl (FIELD_DECL,
819 get_identifier ("handle"),
820 integer_type_node);
821 DECL_INITIAL (decl2) = NULL_TREE;
822 TREE_CHAIN (decl1) = decl2;
823 decl1 = decl2;
824
825 decl2 = build_decl (FIELD_DECL,
826 get_identifier ("bufptr"),
827 ptr_type_node);
828 DECL_INITIAL (decl2) = NULL_TREE;
829 TREE_CHAIN (decl1) = decl2;
830 decl1 = decl2;
831
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;
837 decl1 = decl2;
838
839 decl2 = build_decl (FIELD_DECL,
840 get_identifier ("usage"),
841 char_type_node);
842 DECL_INITIAL (decl2) = NULL_TREE;
843 TREE_CHAIN (decl1) = decl2;
844 decl1 = decl2;
845
846 decl2 = build_decl (FIELD_DECL,
847 get_identifier ("ctl_pre"),
848 char_type_node);
849 DECL_INITIAL (decl2) = NULL_TREE;
850 TREE_CHAIN (decl1) = decl2;
851 decl1 = decl2;
852
853 decl2 = build_decl (FIELD_DECL,
854 get_identifier ("ctl_post"),
855 char_type_node);
856 DECL_INITIAL (decl2) = NULL_TREE;
857 TREE_CHAIN (decl1) = decl2;
858 TREE_CHAIN (decl2) = NULL_TREE;
859
860 result = build_chill_struct_type (listbase);
861 pushdecl (association = build_decl (TYPE_DECL,
862 ridpointers[(int)RID_ASSOCIATION],
863 result));
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;
871
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 */
885 NULL_TREE))))))))));
886
887 /* the type for stdin, stdout, stderr */
888 /* text part */
889 decl1 = build_decl (FIELD_DECL,
890 get_identifier ("flags"),
891 long_unsigned_type_node);
892 DECL_INITIAL (decl1) = NULL_TREE;
893 listbase = decl1;
894
895 decl2 = build_decl (FIELD_DECL,
896 get_identifier ("text_record"),
897 ptr_type_node);
898 DECL_INITIAL (decl2) = NULL_TREE;
899 TREE_CHAIN (decl1) = decl2;
900 decl1 = decl2;
901
902 decl2 = build_decl (FIELD_DECL,
903 get_identifier ("access_sub"),
904 ptr_type_node);
905 DECL_INITIAL (decl2) = NULL_TREE;
906 TREE_CHAIN (decl1) = decl2;
907 decl1 = decl2;
908
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);
916
917 /* access part */
918 decl1 = build_decl (FIELD_DECL,
919 get_identifier ("flags"),
920 long_unsigned_type_node);
921 DECL_INITIAL (decl1) = NULL_TREE;
922 listbase = decl1;
923
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;
929 decl1 = decl2;
930
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;
936 decl1 = decl2;
937
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;
943 decl2 = decl1;
944
945 decl2 = build_decl (FIELD_DECL,
946 get_identifier ("association"),
947 ptr_type_node);
948 DECL_INITIAL (decl2) = NULL_TREE;
949 TREE_CHAIN (decl1) = decl2;
950 decl1 = decl2;
951
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;
957 decl1 = decl2;
958
959 decl2 = build_decl (FIELD_DECL,
960 get_identifier ("storelocptr"),
961 ptr_type_node);
962 DECL_INITIAL (decl2) = NULL_TREE;
963 TREE_CHAIN (decl1) = decl2;
964 decl1 = decl2;
965
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);
973
974 /* the location */
975 tmp = build_string_type (char_type_node, build_int_2 (STDIO_TEXT_LENGTH, 0));
976 tloc = build_varying_struct (tmp);
977
978 /* now the final mode */
979 decl1 = build_decl (FIELD_DECL, get_identifier ("txt"), txt);
980 listbase = decl1;
981
982 decl2 = build_decl (FIELD_DECL, get_identifier ("acc"), acc);
983 TREE_CHAIN (decl1) = decl2;
984 decl1 = decl2;
985
986 decl2 = build_decl (FIELD_DECL, get_identifier ("tloc"), tloc);
987 TREE_CHAIN (decl1) = decl2;
988 decl1 = decl2;
989
990 decl2 = build_lang_decl (TYPE_DECL, get_identifier ("__indexmode"),
991 void_type_node);
992 TREE_CHAIN (decl1) = decl2;
993 decl1 = decl2;
994
995 decl2 = build_decl (CONST_DECL, get_identifier ("__textlength"),
996 integer_type_node);
997 DECL_INITIAL (decl2) = build_int_2 (STDIO_TEXT_LENGTH, 0);
998 TREE_CHAIN (decl1) = decl2;
999 decl1 = decl2;
1000
1001 decl2 = build_decl (CONST_DECL, get_identifier ("__dynamic"),
1002 integer_type_node);
1003 DECL_INITIAL (decl2) = integer_zero_node;
1004 TREE_CHAIN (decl1) = decl2;
1005 TREE_CHAIN (decl2) = NULL_TREE;
1006
1007 result = build_chill_struct_type (listbase);
1008 pushdecl (tmp = build_decl (TYPE_DECL,
1009 get_identifier ("__stdio_text"),
1010 result));
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;
1015
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"),
1021 NULL_TREE);
1022 listbase = chainon (result, listbase);
1023 result = build_enumerator (
1024 get_identifier ((ignore_case || ! special_UC) ? "writeonly" : "WRITEONLY"),
1025 NULL_TREE);
1026 listbase = chainon (result, listbase);
1027 result = build_enumerator (
1028 get_identifier ((ignore_case || ! special_UC) ? "readwrite" : "READWRITE"),
1029 NULL_TREE);
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"),
1034 result));
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;
1040
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"),
1046 NULL_TREE);
1047 listbase = chainon (result, listbase);
1048 result = build_enumerator (
1049 get_identifier ((ignore_case || ! special_UC) ? "same" : "SAME"),
1050 NULL_TREE);
1051 listbase = chainon (result, listbase);
1052 result = build_enumerator (
1053 get_identifier ((ignore_case || ! special_UC) ? "last" : "LAST"),
1054 NULL_TREE);
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"),
1059 result));
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;
1065 }
1066 \f
1067 static void
1068 declare_predefined_file (name, assembler_name)
1069 const char *name;
1070 const char *assembler_name;
1071 {
1072 tree decl = build_lang_decl (VAR_DECL, get_identifier (name),
1073 stdio_type_node);
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);
1080 pushdecl (decl);
1081 }
1082 \f
1083
1084 /* initialisation of all IO/related functions, types, etc. */
1085 void
1086 inout_init ()
1087 {
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;
1092
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;
1108
1109 maximum_field_alignment = 0;
1110
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);
1195
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,
1202 endlink))));
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,
1212 endlink))))))));
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,
1218 endlink))));
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,
1228 endlink))))))));
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,
1239 endlink)))))))));
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,
1245 endlink))));
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,
1251 endlink))));
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,
1259 endlink))))));
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,
1268 endlink)))))));
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,
1274 endlink))));
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,
1281 endlink)))));
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,
1288 endlink)))));
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,
1299 endlink)))))))));
1300
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);
1361
1362 /* declare ASSOCIATION, ACCESS, and TEXT modes */
1363 build_io_types ();
1364
1365 /* declare the predefined text locations */
1366 declare_predefined_file ((ignore_case || ! special_UC) ? "stdin" : "STDIN",
1367 "chill_stdin");
1368 declare_predefined_file ((ignore_case || ! special_UC) ? "stdout" : "STDOUT",
1369 "chill_stdout");
1370 declare_predefined_file ((ignore_case || ! special_UC) ? "stderr" : "STDERR",
1371 "chill_stderr");
1372
1373 /* last, but not least, build the chill IO-list type */
1374 build_chill_io_list_type ();
1375
1376 maximum_field_alignment = save_maximum_field_alignment;
1377 }
1378 \f
1379 /* function returns the recordmode of an ACCESS */
1380 tree
1381 access_recordmode (access)
1382 tree access;
1383 {
1384 tree field;
1385
1386 if (access == NULL_TREE || TREE_CODE (access) == ERROR_MARK)
1387 return NULL_TREE;
1388 if (! CH_IS_ACCESS_MODE (access))
1389 return NULL_TREE;
1390
1391 field = TYPE_FIELDS (access);
1392 for ( ; field != NULL_TREE; field = TREE_CHAIN (field))
1393 {
1394 if (TREE_CODE (field) == TYPE_DECL &&
1395 DECL_NAME (field) == get_identifier ("__recordmode"))
1396 return TREE_TYPE (field);
1397 }
1398 return void_type_node;
1399 }
1400
1401 /* function invalidates the recordmode of an ACCESS */
1402 void
1403 invalidate_access_recordmode (access)
1404 tree access;
1405 {
1406 tree field;
1407
1408 if (access == NULL_TREE || TREE_CODE (access) == ERROR_MARK)
1409 return;
1410 if (! CH_IS_ACCESS_MODE (access))
1411 return;
1412
1413 field = TYPE_FIELDS (access);
1414 for ( ; field != NULL_TREE; field = TREE_CHAIN (field))
1415 {
1416 if (TREE_CODE (field) == TYPE_DECL &&
1417 DECL_NAME (field) == get_identifier ("__recordmode"))
1418 {
1419 TREE_TYPE (field) = error_mark_node;
1420 return;
1421 }
1422 }
1423 }
1424
1425 /* function returns the index mode of an ACCESS if there is one,
1426 otherwise NULL_TREE */
1427 tree
1428 access_indexmode (access)
1429 tree access;
1430 {
1431 tree field;
1432
1433 if (access == NULL_TREE || TREE_CODE (access) == ERROR_MARK)
1434 return NULL_TREE;
1435 if (! CH_IS_ACCESS_MODE (access))
1436 return NULL_TREE;
1437
1438 field = TYPE_FIELDS (access);
1439 for ( ; field != NULL_TREE; field = TREE_CHAIN (field))
1440 {
1441 if (TREE_CODE (field) == TYPE_DECL &&
1442 DECL_NAME (field) == get_identifier ("__indexmode"))
1443 return TREE_TYPE (field);
1444 }
1445 return void_type_node;
1446 }
1447
1448 /* function returns one if an ACCESS was specified DYNAMIC, otherwise zero */
1449 tree
1450 access_dynamic (access)
1451 tree access;
1452 {
1453 tree field;
1454
1455 if (access == NULL_TREE || TREE_CODE (access) == ERROR_MARK)
1456 return NULL_TREE;
1457 if (! CH_IS_ACCESS_MODE (access))
1458 return NULL_TREE;
1459
1460 field = TYPE_FIELDS (access);
1461 for ( ; field != NULL_TREE; field = TREE_CHAIN (field))
1462 {
1463 if (TREE_CODE (field) == CONST_DECL)
1464 return DECL_INITIAL (field);
1465 }
1466 return integer_zero_node;
1467 }
1468
1469 /*
1470 returns a structure like
1471 STRUCT (data STRUCT (flags ULONG,
1472 reclength ULONG,
1473 lowindex LONG,
1474 highindex LONG,
1475 association PTR,
1476 base ULONG,
1477 store_loc PTR,
1478 rectype LONG),
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
1483 */
1484
1485 static tree
1486 build_access_part ()
1487 {
1488 tree listbase, decl;
1489
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"),
1502 ptr_type_node);
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"),
1508 ptr_type_node);
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);
1514 }
1515
1516 tree
1517 build_access_mode (indexmode, recordmode, dynamic)
1518 tree indexmode;
1519 tree recordmode;
1520 int dynamic;
1521 {
1522 tree type, listbase, decl, datamode;
1523
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;
1528
1529 datamode = build_access_part ();
1530
1531 type = make_node (RECORD_TYPE);
1532 listbase = build_decl (FIELD_DECL, get_identifier ("data"),
1533 datamode);
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"),
1542 integer_type_node);
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;
1547 return type;
1548 }
1549 \f
1550 /*
1551 returns a structure like:
1552 STRUCT (txt STRUCT (flags ULONG,
1553 text_record PTR,
1554 access_sub PTR,
1555 actual_index LONG),
1556 acc STRUCT (flags ULONG,
1557 reclength ULONG,
1558 lowindex LONG,
1559 highindex LONG,
1560 association PTR,
1561 base ULONG,
1562 store_loc PTR,
1563 rectype LONG),
1564 tloc CHARS(textlength) VARYING;
1565 )
1566 followed by
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
1570 */
1571 tree
1572 build_text_mode (textlength, indexmode, dynamic)
1573 tree textlength;
1574 tree indexmode;
1575 int dynamic;
1576 {
1577 tree txt, acc, listbase, decl, type, tltype;
1578 tree savedlength = textlength;
1579
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;
1584
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"),
1589 ptr_type_node);
1590 listbase = chainon (listbase, decl);
1591 decl = build_decl (FIELD_DECL, get_identifier ("access_sub"),
1592 ptr_type_node);
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);
1598
1599 acc = build_access_part ();
1600
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"),
1610 tltype);
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);
1616 /* save dynamic */
1617 decl = build_decl (CONST_DECL, get_identifier ("__textlength"),
1618 integer_type_node);
1619 if (TREE_CODE (textlength) == COMPONENT_REF)
1620 /* FIXME: we cannot use one and the same COMPONENT_REF twice, so build
1621 another one */
1622 savedlength = build_component_ref (TREE_OPERAND (textlength, 0),
1623 TREE_OPERAND (textlength, 1));
1624 DECL_INITIAL (decl) = savedlength;
1625 chainon (listbase, decl);
1626 /* save dynamic */
1627 decl = build_decl (CONST_DECL, get_identifier ("__dynamic"),
1628 integer_type_node);
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;
1633 return type;
1634 }
1635
1636 tree
1637 check_text_length (length)
1638 tree length;
1639 {
1640 if (length == NULL_TREE || TREE_CODE (length) == ERROR_MARK)
1641 return length;
1642 if (TREE_TYPE (length) == NULL_TREE
1643 || !CH_SIMILAR (TREE_TYPE (length), integer_type_node))
1644 {
1645 error ("non-integral text length");
1646 return integer_one_node;
1647 }
1648 if (TREE_CODE (length) != INTEGER_CST)
1649 {
1650 error ("non-constant text length");
1651 return integer_one_node;
1652 }
1653 if (compare_int_csts (LE_EXPR, length, integer_zero_node))
1654 {
1655 error ("text length must be greater then 0");
1656 return integer_one_node;
1657 }
1658 return length;
1659 }
1660
1661 tree
1662 text_indexmode (text)
1663 tree text;
1664 {
1665 tree field;
1666
1667 if (text == NULL_TREE || TREE_CODE (text) == ERROR_MARK)
1668 return NULL_TREE;
1669 if (! CH_IS_TEXT_MODE (text))
1670 return NULL_TREE;
1671
1672 field = TYPE_FIELDS (text);
1673 for ( ; field != NULL_TREE; field = TREE_CHAIN (field))
1674 {
1675 if (TREE_CODE (field) == TYPE_DECL)
1676 return TREE_TYPE (field);
1677 }
1678 return void_type_node;
1679 }
1680
1681 tree
1682 text_dynamic (text)
1683 tree text;
1684 {
1685 tree field;
1686
1687 if (text == NULL_TREE || TREE_CODE (text) == ERROR_MARK)
1688 return NULL_TREE;
1689 if (! CH_IS_TEXT_MODE (text))
1690 return NULL_TREE;
1691
1692 field = TYPE_FIELDS (text);
1693 for ( ; field != NULL_TREE; field = TREE_CHAIN (field))
1694 {
1695 if (TREE_CODE (field) == CONST_DECL &&
1696 DECL_NAME (field) == get_identifier ("__dynamic"))
1697 return DECL_INITIAL (field);
1698 }
1699 return integer_zero_node;
1700 }
1701
1702 tree
1703 text_length (text)
1704 tree text;
1705 {
1706 tree field;
1707
1708 if (text == NULL_TREE || TREE_CODE (text) == ERROR_MARK)
1709 return NULL_TREE;
1710 if (! CH_IS_TEXT_MODE (text))
1711 return NULL_TREE;
1712
1713 field = TYPE_FIELDS (text);
1714 for ( ; field != NULL_TREE; field = TREE_CHAIN (field))
1715 {
1716 if (TREE_CODE (field) == CONST_DECL &&
1717 DECL_NAME (field) == get_identifier ("__textlength"))
1718 return DECL_INITIAL (field);
1719 }
1720 return integer_zero_node;
1721 }
1722
1723 static tree
1724 textlocation_mode (text)
1725 tree text;
1726 {
1727 tree field;
1728
1729 if (text == NULL_TREE || TREE_CODE (text) == ERROR_MARK)
1730 return NULL_TREE;
1731 if (! CH_IS_TEXT_MODE (text))
1732 return NULL_TREE;
1733
1734 field = TYPE_FIELDS (text);
1735 for ( ; field != NULL_TREE; field = TREE_CHAIN (field))
1736 {
1737 if (TREE_CODE (field) == FIELD_DECL &&
1738 DECL_NAME (field) == get_identifier ("tloc"))
1739 return TREE_TYPE (field);
1740 }
1741 return NULL_TREE;
1742 }
1743 \f
1744 static int
1745 check_assoc (assoc, argnum, errmsg)
1746 tree assoc;
1747 int argnum;
1748 const char *errmsg;
1749 {
1750 if (assoc == NULL_TREE || TREE_CODE (assoc) == ERROR_MARK)
1751 return 0;
1752
1753 if (! CH_IS_ASSOCIATION_MODE (TREE_TYPE (assoc)))
1754 {
1755 error ("argument %d of %s must be of mode ASSOCIATION", argnum, errmsg);
1756 return 0;
1757 }
1758 if (! CH_LOCATION_P (assoc))
1759 {
1760 error ("argument %d of %s must be a location", argnum, errmsg);
1761 return 0;
1762 }
1763 return 1;
1764 }
1765
1766 tree
1767 build_chill_associate (assoc, fname, attr)
1768 tree assoc;
1769 tree fname;
1770 tree attr;
1771 {
1772 tree arg1 = NULL_TREE, arg2 = NULL_TREE, arg3 = NULL_TREE, arg4 = NULL_TREE,
1773 arg5 = NULL_TREE, arg6, arg7;
1774 int had_errors = 0;
1775 tree result;
1776
1777 /* make some checks */
1778 if (fname == NULL_TREE || TREE_CODE (fname) == ERROR_MARK)
1779 return error_mark_node;
1780
1781 /* check the association */
1782 if (! check_assoc (assoc, 1, "ASSOCIATION"))
1783 had_errors = 1;
1784 else
1785 /* build a pointer to the association */
1786 arg1 = force_addr_of (assoc);
1787
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))
1792 {
1793 if (int_size_in_bytes (TREE_TYPE (fname)) == 0)
1794 {
1795 error ("argument 2 of ASSOCIATE must not be an empty string");
1796 had_errors = 1;
1797 }
1798 else
1799 {
1800 arg2 = force_addr_of (fname);
1801 arg3 = size_in_bytes (TREE_TYPE (fname));
1802 }
1803 }
1804 else if (chill_varying_string_type_p (TREE_TYPE (fname)))
1805 {
1806 arg2 = force_addr_of (build_component_ref (fname, var_data_id));
1807 arg3 = build_component_ref (fname, var_length_id);
1808 }
1809 else
1810 {
1811 error ("argument 2 to ASSOCIATE must be a string");
1812 had_errors = 1;
1813 }
1814
1815 /* check attr argument, must be a string too */
1816 if (attr == NULL_TREE)
1817 {
1818 arg4 = null_pointer_node;
1819 arg5 = integer_zero_node;
1820 }
1821 else
1822 {
1823 attr = TREE_VALUE (attr);
1824 if (attr == NULL_TREE || TREE_CODE (attr) == ERROR_MARK)
1825 had_errors = 1;
1826 else
1827 {
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))
1831 {
1832 if (int_size_in_bytes (TREE_TYPE (attr)) == 0)
1833 {
1834 arg4 = null_pointer_node;
1835 arg5 = integer_zero_node;
1836 }
1837 else
1838 {
1839 arg4 = force_addr_of (attr);
1840 arg5 = size_in_bytes (TREE_TYPE (attr));
1841 }
1842 }
1843 else if (chill_varying_string_type_p (TREE_TYPE (attr)))
1844 {
1845 arg4 = force_addr_of (build_component_ref (attr, var_data_id));
1846 arg5 = build_component_ref (attr, var_length_id);
1847 }
1848 else
1849 {
1850 error ("argument 3 to ASSOCIATE must be a string");
1851 had_errors = 1;
1852 }
1853 }
1854 }
1855
1856 if (had_errors)
1857 return error_mark_node;
1858
1859 /* other arguments */
1860 arg6 = force_addr_of (get_chill_filename ());
1861 arg7 = get_chill_linenumber ();
1862
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))))))));
1872
1873 TREE_TYPE (result) = build_chill_pointer_type (TREE_TYPE (assoc));
1874 return result;
1875 }
1876
1877 static tree
1878 assoc_call (assoc, func, name)
1879 tree assoc;
1880 tree func;
1881 const char *name;
1882 {
1883 tree arg1, arg2, arg3;
1884 tree result;
1885
1886 if (! check_assoc (assoc, 1, name))
1887 return error_mark_node;
1888
1889 arg1 = force_addr_of (assoc);
1890 arg2 = force_addr_of (get_chill_filename ());
1891 arg3 = get_chill_linenumber ();
1892
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))));
1897 return result;
1898 }
1899
1900 tree
1901 build_chill_isassociated (assoc)
1902 tree assoc;
1903 {
1904 tree result = assoc_call (assoc,
1905 lookup_name (get_identifier ("__isassociated")),
1906 "ISASSOCIATED");
1907 return result;
1908 }
1909
1910 tree
1911 build_chill_existing (assoc)
1912 tree assoc;
1913 {
1914 tree result = assoc_call (assoc,
1915 lookup_name (get_identifier ("__existing")),
1916 "EXISTING");
1917 return result;
1918 }
1919
1920 tree
1921 build_chill_readable (assoc)
1922 tree assoc;
1923 {
1924 tree result = assoc_call (assoc,
1925 lookup_name (get_identifier ("__readable")),
1926 "READABLE");
1927 return result;
1928 }
1929
1930 tree
1931 build_chill_writeable (assoc)
1932 tree assoc;
1933 {
1934 tree result = assoc_call (assoc,
1935 lookup_name (get_identifier ("__writeable")),
1936 "WRITEABLE");
1937 return result;
1938 }
1939
1940 tree
1941 build_chill_sequencible (assoc)
1942 tree assoc;
1943 {
1944 tree result = assoc_call (assoc,
1945 lookup_name (get_identifier ("__sequencible")),
1946 "SEQUENCIBLE");
1947 return result;
1948 }
1949
1950 tree
1951 build_chill_variable (assoc)
1952 tree assoc;
1953 {
1954 tree result = assoc_call (assoc,
1955 lookup_name (get_identifier ("__variable")),
1956 "VARIABLE");
1957 return result;
1958 }
1959
1960 tree
1961 build_chill_indexable (assoc)
1962 tree assoc;
1963 {
1964 tree result = assoc_call (assoc,
1965 lookup_name (get_identifier ("__indexable")),
1966 "INDEXABLE");
1967 return result;
1968 }
1969
1970 tree
1971 build_chill_dissociate (assoc)
1972 tree assoc;
1973 {
1974 tree result = assoc_call (assoc,
1975 lookup_name (get_identifier ("__dissociate")),
1976 "DISSOCIATE");
1977 return result;
1978 }
1979
1980 tree
1981 build_chill_create (assoc)
1982 tree assoc;
1983 {
1984 tree result = assoc_call (assoc,
1985 lookup_name (get_identifier ("__create")),
1986 "CREATE");
1987 return result;
1988 }
1989
1990 tree
1991 build_chill_delete (assoc)
1992 tree assoc;
1993 {
1994 tree result = assoc_call (assoc,
1995 lookup_name (get_identifier ("__delete")),
1996 "DELETE");
1997 return result;
1998 }
1999
2000 tree
2001 build_chill_modify (assoc, list)
2002 tree assoc;
2003 tree list;
2004 {
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;
2009 tree result;
2010
2011 /* check the association */
2012 if (! check_assoc (assoc, 1, "MODIFY"))
2013 had_errors = 1;
2014 else
2015 arg1 = force_addr_of (assoc);
2016
2017 /* look how much arguments we have got */
2018 numargs = list_length (list);
2019 switch (numargs)
2020 {
2021 case 0:
2022 break;
2023 case 1:
2024 fname = TREE_VALUE (list);
2025 break;
2026 case 2:
2027 fname = TREE_VALUE (list);
2028 attr = TREE_VALUE (TREE_CHAIN (list));
2029 break;
2030 default:
2031 error ("too many arguments in call to MODIFY");
2032 had_errors = 1;
2033 break;
2034 }
2035
2036 if (fname != NULL_TREE && fname != null_pointer_node)
2037 {
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))
2041 {
2042 if (int_size_in_bytes (TREE_TYPE (fname)) == 0)
2043 {
2044 error ("argument 2 of MODIFY must not be an empty string");
2045 had_errors = 1;
2046 }
2047 else
2048 {
2049 arg2 = force_addr_of (fname);
2050 arg3 = size_in_bytes (TREE_TYPE (fname));
2051 }
2052 }
2053 else if (chill_varying_string_type_p (TREE_TYPE (fname)))
2054 {
2055 arg2 = force_addr_of (build_component_ref (fname, var_data_id));
2056 arg3 = build_component_ref (fname, var_length_id);
2057 }
2058 else
2059 {
2060 error ("argument 2 to MODIFY must be a string");
2061 had_errors = 1;
2062 }
2063 }
2064 else
2065 {
2066 arg2 = null_pointer_node;
2067 arg3 = integer_zero_node;
2068 }
2069
2070 if (attr != NULL_TREE && attr != null_pointer_node)
2071 {
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))
2075 {
2076 if (int_size_in_bytes (TREE_TYPE (attr)) == 0)
2077 {
2078 arg4 = null_pointer_node;
2079 arg5 = integer_zero_node;
2080 }
2081 else
2082 {
2083 arg4 = force_addr_of (attr);
2084 arg5 = size_in_bytes (TREE_TYPE (attr));
2085 }
2086 }
2087 else if (chill_varying_string_type_p (TREE_TYPE (attr)))
2088 {
2089 arg4 = force_addr_of (build_component_ref (attr, var_data_id));
2090 arg5 = build_component_ref (attr, var_length_id);
2091 }
2092 else
2093 {
2094 error ("argument 3 to MODIFY must be a string");
2095 had_errors = 1;
2096 }
2097 }
2098 else
2099 {
2100 arg4 = null_pointer_node;
2101 arg5 = integer_zero_node;
2102 }
2103
2104 if (had_errors)
2105 return error_mark_node;
2106
2107 /* other arguments */
2108 arg6 = force_addr_of (get_chill_filename ());
2109 arg7 = get_chill_linenumber ();
2110
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))))))));
2120
2121 return result;
2122 }
2123 \f
2124 static int
2125 check_transfer (transfer, argnum, errmsg)
2126 tree transfer;
2127 int argnum;
2128 const char *errmsg;
2129 {
2130 int result = 0;
2131
2132 if (transfer == NULL_TREE || TREE_CODE (transfer) == ERROR_MARK)
2133 return 0;
2134
2135 if (CH_IS_ACCESS_MODE (TREE_TYPE (transfer)))
2136 result = 1;
2137 else if (CH_IS_TEXT_MODE (TREE_TYPE (transfer)))
2138 result = 2;
2139 else
2140 {
2141 error ("argument %d of %s must be an ACCESS or TEXT mode", argnum, errmsg);
2142 return 0;
2143 }
2144 if (! CH_LOCATION_P (transfer))
2145 {
2146 error ("argument %d of %s must be a location", argnum, errmsg);
2147 return 0;
2148 }
2149 return result;
2150 }
2151
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
2158 \f
2159 /* generated initialisation code for ACCESS and TEXT.
2160 functions gets called from do_decl. */
2161 void init_access_location (decl, type)
2162 tree decl;
2163 tree type;
2164 {
2165 tree recordmode = access_recordmode (type);
2166 tree indexmode = access_indexmode (type);
2167 int flags_init = 0;
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;
2172
2173 /* flag word */
2174 if (indexmode != NULL_TREE && indexmode != void_type_node)
2175 {
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));
2179 }
2180
2181 expand_expr_stmt (
2182 build_chill_modify_expr (
2183 build_component_ref (data, get_identifier ("flags")),
2184 build_int_2 (flags_init, 0)));
2185
2186 /* record length */
2187 if (recordmode == NULL_TREE || recordmode == void_type_node)
2188 {
2189 reclen = integer_zero_node;
2190 rectype = integer_zero_node;
2191 }
2192 else if (chill_varying_string_type_p (recordmode))
2193 {
2194 tree fields = TYPE_FIELDS (recordmode);
2195 tree len1, len2;
2196
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);
2203 }
2204 else
2205 {
2206 reclen = size_in_bytes (recordmode);
2207 rectype = integer_one_node;
2208 }
2209 expand_expr_stmt (
2210 build_chill_modify_expr (
2211 build_component_ref (data, get_identifier ("reclength")), reclen));
2212
2213 /* record type */
2214 expand_expr_stmt (
2215 build_chill_modify_expr (
2216 build_component_ref (data, get_identifier ("rectype")), rectype));
2217
2218 /* the index */
2219 expand_expr_stmt (
2220 build_chill_modify_expr (
2221 build_component_ref (data, get_identifier ("lowindex")), lowindex));
2222 expand_expr_stmt (
2223 build_chill_modify_expr (
2224 build_component_ref (data, get_identifier ("highindex")), highindex));
2225
2226 /* association */
2227 expand_expr_stmt (
2228 build_chill_modify_expr (
2229 build_chill_component_ref (data, get_identifier ("association")),
2230 null_pointer_node));
2231
2232 /* storelocptr */
2233 expand_expr_stmt (
2234 build_chill_modify_expr (
2235 build_component_ref (data, get_identifier ("storelocptr")), null_pointer_node));
2236 }
2237
2238 void init_text_location (decl, type)
2239 tree decl;
2240 tree type;
2241 {
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;
2248
2249 if (indexmode != NULL_TREE && indexmode != void_type_node)
2250 {
2251 accessflags |= IO_INDEXED;
2252 lowindex = convert (integer_type_node, TYPE_MIN_VALUE (indexmode));
2253 highindex = convert (integer_type_node, TYPE_MAX_VALUE (indexmode));
2254 }
2255
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"));
2259 /* flag word */
2260 expand_expr_stmt (
2261 build_chill_modify_expr (
2262 build_component_ref (data, get_identifier ("flags")),
2263 build_int_2 (accessflags, 0)));
2264
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));
2271 expand_expr_stmt (
2272 build_chill_modify_expr (
2273 build_component_ref (data, get_identifier ("reclength")),
2274 reclen));
2275
2276 /* the index */
2277 expand_expr_stmt (
2278 build_chill_modify_expr (
2279 build_component_ref (data, get_identifier ("lowindex")), lowindex));
2280 expand_expr_stmt (
2281 build_chill_modify_expr (
2282 build_component_ref (data, get_identifier ("highindex")), highindex));
2283
2284 /* association */
2285 expand_expr_stmt (
2286 build_chill_modify_expr (
2287 build_chill_component_ref (data, get_identifier ("association")),
2288 null_pointer_node));
2289
2290 /* storelocptr */
2291 expand_expr_stmt (
2292 build_chill_modify_expr (
2293 build_component_ref (data, get_identifier ("storelocptr")),
2294 null_pointer_node));
2295
2296 /* record type */
2297 expand_expr_stmt (
2298 build_chill_modify_expr (
2299 build_component_ref (data, get_identifier ("rectype")),
2300 build_int_2 (2, 0))); /* VaryingChars */
2301
2302 /* fill text part */
2303 data = build_component_ref (decl, get_identifier ("txt"));
2304 /* flag word */
2305 expand_expr_stmt (
2306 build_chill_modify_expr (
2307 build_component_ref (data, get_identifier ("flags")),
2308 build_int_2 (textflags, 0)));
2309
2310 /* pointer to text record */
2311 expand_expr_stmt (
2312 build_chill_modify_expr (
2313 build_component_ref (data, get_identifier ("text_record")),
2314 force_addr_of (tloc)));
2315
2316 /* pointer to the access */
2317 expand_expr_stmt (
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")))));
2321
2322 /* actual length */
2323 expand_expr_stmt (
2324 build_chill_modify_expr (
2325 build_component_ref (data, get_identifier ("actual_index")),
2326 integer_zero_node));
2327
2328 /* length of text record */
2329 expand_expr_stmt (
2330 build_chill_modify_expr (
2331 build_component_ref (tloc, get_identifier (VAR_LENGTH)),
2332 integer_zero_node));
2333 }
2334 \f
2335 static int
2336 connect_process_optionals (optionals, whereptr, indexptr, indexmode)
2337 tree optionals;
2338 tree *whereptr;
2339 tree *indexptr;
2340 tree indexmode;
2341 {
2342 tree where = NULL_TREE, theindex = NULL_TREE;
2343 int had_errors = 0;
2344
2345 if (optionals != NULL_TREE)
2346 {
2347 /* get the where expression */
2348 where = TREE_VALUE (optionals);
2349 if (where == NULL_TREE || TREE_CODE (where) == ERROR_MARK)
2350 had_errors = 1;
2351 else
2352 {
2353 if (! CH_IS_WHERE_MODE (TREE_TYPE (where)))
2354 {
2355 error ("argument 4 of CONNECT must be of mode WHERE");
2356 had_errors = 1;
2357 }
2358 where = convert (integer_type_node, where);
2359 }
2360 optionals = TREE_CHAIN (optionals);
2361 }
2362 if (optionals != NULL_TREE)
2363 {
2364 theindex = TREE_VALUE (optionals);
2365 if (theindex == NULL_TREE || TREE_CODE (theindex) == ERROR_MARK)
2366 had_errors = 1;
2367 else
2368 {
2369 if (indexmode == void_type_node)
2370 {
2371 error ("index expression for ACCESS without index");
2372 had_errors = 1;
2373 }
2374 else if (! CH_COMPATIBLE (theindex, indexmode))
2375 {
2376 error ("incompatible index mode");
2377 had_errors = 1;
2378 }
2379 }
2380 }
2381 if (had_errors)
2382 return 0;
2383
2384 *whereptr = where;
2385 *indexptr = theindex;
2386 return 1;
2387 }
2388
2389 static tree
2390 connect_text (assoc, text, usage, optionals)
2391 tree assoc;
2392 tree text;
2393 tree usage;
2394 tree optionals;
2395 {
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;
2399
2400 /* process optionals */
2401 if (!connect_process_optionals (optionals, &where, &theindex, indexmode))
2402 return error_mark_node;
2403
2404 what_where = where == NULL_TREE ? integer_zero_node : where;
2405 have_index = theindex == NULL_TREE ? integer_zero_node
2406 : integer_one_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 (),
2419 NULL_TREE)))))))));
2420 return result;
2421 }
2422
2423 static tree
2424 connect_access (assoc, transfer, usage, optionals)
2425 tree assoc;
2426 tree transfer;
2427 tree usage;
2428 tree optionals;
2429 {
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;
2433
2434 /* process the optionals */
2435 if (! connect_process_optionals (optionals, &where, &theindex, indexmode))
2436 return error_mark_node;
2437
2438 /* now the call */
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 (),
2452 NULL_TREE)))))))));
2453 return result;
2454 }
2455
2456 tree
2457 build_chill_connect (transfer, assoc, usage, optionals)
2458 tree transfer;
2459 tree assoc;
2460 tree usage;
2461 tree optionals;
2462 {
2463 int had_errors = 0;
2464 int what = 0;
2465 tree result = error_mark_node;
2466
2467 if (! check_assoc (assoc, 2, "CONNECT"))
2468 had_errors = 1;
2469
2470 /* check usage */
2471 if (usage == NULL_TREE || TREE_CODE (usage) == ERROR_MARK)
2472 return error_mark_node;
2473
2474 if (! CH_IS_USAGE_MODE (TREE_TYPE (usage)))
2475 {
2476 error ("argument 3 to CONNECT must be of mode USAGE");
2477 had_errors = 1;
2478 }
2479 if (had_errors)
2480 return error_mark_node;
2481
2482 /* look what we have got */
2483 what = check_transfer (transfer, 1, "CONNECT");
2484 switch (what)
2485 {
2486 case 1:
2487 /* we have an ACCESS */
2488 result = connect_access (assoc, transfer, usage, optionals);
2489 break;
2490 case 2:
2491 /* we have a TEXT */
2492 result = connect_text (assoc, transfer, usage, optionals);
2493 break;
2494 default:
2495 result = error_mark_node;
2496 }
2497 return result;
2498 }
2499
2500 static int
2501 check_access (access, argnum, errmsg)
2502 tree access;
2503 int argnum;
2504 const char *errmsg;
2505 {
2506 if (access == NULL_TREE || TREE_CODE (access) == ERROR_MARK)
2507 return 1;
2508
2509 if (! CH_IS_ACCESS_MODE (TREE_TYPE (access)))
2510 {
2511 error ("argument %d of %s must be of mode ACCESS", argnum, errmsg);
2512 return 0;
2513 }
2514 if (! CH_LOCATION_P (access))
2515 {
2516 error ("argument %d of %s must be a location", argnum, errmsg);
2517 return 0;
2518 }
2519 return 1;
2520 }
2521
2522 tree
2523 build_chill_readrecord (access, optionals)
2524 tree access;
2525 tree optionals;
2526 {
2527 int len;
2528 tree recordmode, indexmode, dynamic, result;
2529 tree index = NULL_TREE, location = NULL_TREE;
2530
2531 if (! check_access (access, 1, "READRECORD"))
2532 return error_mark_node;
2533
2534 recordmode = access_recordmode (TREE_TYPE (access));
2535 indexmode = access_indexmode (TREE_TYPE (access));
2536 dynamic = access_dynamic (TREE_TYPE (access));
2537
2538 /* process the optionals */
2539 len = list_length (optionals);
2540 if (indexmode != void_type_node)
2541 {
2542 /* we must have an index */
2543 if (!len)
2544 {
2545 error ("too few arguments in call to `readrecord'");
2546 return error_mark_node;
2547 }
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))
2553 {
2554 error ("incompatible index mode");
2555 return error_mark_node;
2556 }
2557 }
2558
2559 /* check the record mode, if one */
2560 if (optionals != NULL_TREE)
2561 {
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))
2567 {
2568
2569 error ("incompatible record mode");
2570 return error_mark_node;
2571 }
2572 if (TYPE_READONLY_PROPERTY (TREE_TYPE (location)))
2573 {
2574 error ("store location must not be READonly");
2575 return error_mark_node;
2576 }
2577 location = force_addr_of (location);
2578 }
2579 else
2580 location = null_pointer_node;
2581
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))))));
2590
2591 TREE_TYPE (result) = build_chill_pointer_type (recordmode);
2592 return result;
2593 }
2594
2595 tree
2596 build_chill_writerecord (access, optionals)
2597 tree access;
2598 tree optionals;
2599 {
2600 int had_errors = 0, len;
2601 tree recordmode, indexmode, dynamic;
2602 tree index = NULL_TREE, location = NULL_TREE;
2603 tree result;
2604
2605 if (! check_access (access, 1, "WRITERECORD"))
2606 return error_mark_node;
2607
2608 recordmode = access_recordmode (TREE_TYPE (access));
2609 indexmode = access_indexmode (TREE_TYPE (access));
2610 dynamic = access_dynamic (TREE_TYPE (access));
2611
2612 /* process the optionals */
2613 len = list_length (optionals);
2614 if (indexmode != void_type_node && len != 2)
2615 {
2616 error ("too few arguments in call to `writerecord'");
2617 return error_mark_node;
2618 }
2619 if (indexmode != void_type_node)
2620 {
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;
2627 }
2628 else
2629 location = TREE_VALUE (optionals);
2630
2631 /* check the index */
2632 if (indexmode != void_type_node)
2633 {
2634 if (! CH_COMPATIBLE (index, indexmode))
2635 {
2636 error ("incompatible index mode");
2637 had_errors = 1;
2638 }
2639 }
2640 /* check the record mode */
2641 if (recordmode == void_type_node)
2642 {
2643 error ("transfer to ACCESS without record mode");
2644 had_errors = 1;
2645 }
2646 else if (! CH_COMPATIBLE (location, recordmode))
2647 {
2648 error ("incompatible record mode");
2649 had_errors = 1;
2650 }
2651 if (had_errors)
2652 return error_mark_node;
2653
2654 index = index == NULL_TREE ? integer_zero_node : convert (integer_type_node, index);
2655
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)))))));
2664 return result;
2665 }
2666
2667 tree
2668 build_chill_disconnect (transfer)
2669 tree transfer;
2670 {
2671 tree result;
2672
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))));
2680 return result;
2681 }
2682
2683 tree
2684 build_chill_getassociation (transfer)
2685 tree transfer;
2686 {
2687 tree result;
2688
2689 if (! check_transfer (transfer, 1, "GETASSOCIATION"))
2690 return error_mark_node;
2691
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);
2698 return result;
2699 }
2700
2701 tree
2702 build_chill_getusage (transfer)
2703 tree transfer;
2704 {
2705 tree result;
2706
2707 if (! check_transfer (transfer, 1, "GETUSAGE"))
2708 return error_mark_node;
2709
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;
2716 return result;
2717 }
2718
2719 tree
2720 build_chill_outoffile (transfer)
2721 tree transfer;
2722 {
2723 tree result;
2724
2725 if (! check_transfer (transfer, 1, "OUTOFFILE"))
2726 return error_mark_node;
2727
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))));
2733 return result;
2734 }
2735 \f
2736 static int
2737 check_text (text, argnum, errmsg)
2738 tree text;
2739 int argnum;
2740 const char *errmsg;
2741 {
2742 if (text == NULL_TREE || TREE_CODE (text) == ERROR_MARK)
2743 return 0;
2744 if (! CH_IS_TEXT_MODE (TREE_TYPE (text)))
2745 {
2746 error ("argument %d of %s must be of mode TEXT", argnum, errmsg);
2747 return 0;
2748 }
2749 if (! CH_LOCATION_P (text))
2750 {
2751 error ("argument %d of %s must be a location", argnum, errmsg);
2752 return 0;
2753 }
2754 return 1;
2755 }
2756
2757 tree
2758 build_chill_eoln (text)
2759 tree text;
2760 {
2761 tree result;
2762
2763 if (! check_text (text, 1, "EOLN"))
2764 return error_mark_node;
2765
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))));
2771 return result;
2772 }
2773
2774 tree
2775 build_chill_gettextindex (text)
2776 tree text;
2777 {
2778 tree result;
2779
2780 if (! check_text (text, 1, "GETTEXTINDEX"))
2781 return error_mark_node;
2782
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))));
2788 return result;
2789 }
2790
2791 tree
2792 build_chill_gettextrecord (text)
2793 tree text;
2794 {
2795 tree textmode, result;
2796
2797 if (! check_text (text, 1, "GETTEXTRECORD"))
2798 return error_mark_node;
2799
2800 textmode = textlocation_mode (TREE_TYPE (text));
2801 if (textmode == NULL_TREE)
2802 {
2803 error ("TEXT doesn't have a location"); /* FIXME */
2804 return error_mark_node;
2805 }
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;
2813 return result;
2814 }
2815
2816 tree
2817 build_chill_gettextaccess (text)
2818 tree text;
2819 {
2820 tree access, refaccess, acc, decl, listbase;
2821 tree tlocmode, indexmode, dynamic;
2822 tree result;
2823 unsigned int save_maximum_field_alignment = maximum_field_alignment;
2824
2825 if (! check_text (text, 1, "GETTEXTACCESS"))
2826 return error_mark_node;
2827
2828 tlocmode = textlocation_mode (TREE_TYPE (text));
2829 indexmode = text_indexmode (TREE_TYPE (text));
2830 dynamic = text_dynamic (TREE_TYPE (text));
2831
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"),
2838 tlocmode);
2839 chainon (listbase, decl);
2840 decl = build_lang_decl (TYPE_DECL, get_identifier ("__indexmode"),
2841 indexmode);
2842 chainon (listbase, decl);
2843 decl = build_decl (CONST_DECL, get_identifier ("__dynamic"),
2844 integer_type_node);
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;
2852
2853 refaccess = build_chill_pointer_type (access);
2854
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;
2862 return result;
2863 }
2864
2865 tree
2866 build_chill_settextindex (text, expr)
2867 tree text;
2868 tree expr;
2869 {
2870 tree result;
2871
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)))));
2882 return result;
2883 }
2884
2885 tree
2886 build_chill_settextaccess (text, access)
2887 tree text;
2888 tree access;
2889 {
2890 tree result;
2891 tree textindexmode, accessindexmode;
2892 tree textrecordmode, accessrecordmode;
2893
2894 if (! check_text (text, 1, "SETTEXTACCESS"))
2895 return error_mark_node;
2896 if (! check_access (access, 2, "SETTEXTACCESS"))
2897 return error_mark_node;
2898
2899 textindexmode = text_indexmode (TREE_TYPE (text));
2900 accessindexmode = access_indexmode (TREE_TYPE (access));
2901 if (textindexmode != accessindexmode)
2902 {
2903 if (! chill_read_compatible (textindexmode, accessindexmode))
2904 {
2905 error ("incompatible index mode for SETETEXTACCESS");
2906 return error_mark_node;
2907 }
2908 }
2909 textrecordmode = textlocation_mode (TREE_TYPE (text));
2910 accessrecordmode = access_recordmode (TREE_TYPE (access));
2911 if (textrecordmode != accessrecordmode)
2912 {
2913 if (! chill_read_compatible (textrecordmode, accessrecordmode))
2914 {
2915 error ("incompatible record mode for SETTEXTACCESS");
2916 return error_mark_node;
2917 }
2918 }
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)))));
2925 return result;
2926 }
2927
2928 tree
2929 build_chill_settextrecord (text, charloc)
2930 tree text;
2931 tree charloc;
2932 {
2933 tree result;
2934 int had_errors = 0;
2935 tree tlocmode;
2936
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;
2941
2942 /* check the location */
2943 if (! CH_LOCATION_P (charloc))
2944 {
2945 error ("parameter 2 must be a location");
2946 return error_mark_node;
2947 }
2948 tlocmode = textlocation_mode (TREE_TYPE (text));
2949 if (! chill_varying_string_type_p (TREE_TYPE (charloc)))
2950 had_errors = 1;
2951 else if (int_size_in_bytes (tlocmode) != int_size_in_bytes (TREE_TYPE (charloc)))
2952 had_errors = 1;
2953 if (had_errors)
2954 {
2955 error ("incompatible modes in parameter 2");
2956 return error_mark_node;
2957 }
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)))));
2964 return result;
2965 }
2966 \f
2967 /* process iolist for READ- and WRITETEXT */
2968
2969 /* function walks through types as long as they are ranges,
2970 returns the type and min- and max-value form starting type.
2971 */
2972
2973 static tree
2974 get_final_type_and_range (item, low, high)
2975 tree item;
2976 tree *low;
2977 tree *high;
2978 {
2979 tree wrk = item;
2980
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);
2988
2989 return (TREE_TYPE (wrk));
2990 }
2991
2992 static void
2993 process_io_list (exprlist, iolist_addr, iolist_length, iolist_rtx, do_read,
2994 argoffset)
2995 tree exprlist;
2996 tree *iolist_addr;
2997 tree *iolist_length;
2998 rtx *iolist_rtx;
2999 int do_read;
3000 int argoffset;
3001 {
3002 tree idxlist;
3003 int idxcnt;
3004 int iolen;
3005 tree iolisttype, iolist;
3006
3007 if (exprlist == NULL_TREE)
3008 return;
3009
3010 iolen = list_length (exprlist);
3011
3012 /* build indexlist for the io list */
3013 idxlist = build_tree_list (NULL_TREE,
3014 build_chill_range_type (NULL_TREE,
3015 integer_one_node,
3016 build_int_2 (iolen, 0)));
3017
3018 /* build the io-list type */
3019 iolisttype = build_chill_array_type (TREE_TYPE (chill_io_list_type),
3020 idxlist, 0, NULL_TREE);
3021
3022 /* declare the iolist */
3023 iolist = build_decl (VAR_DECL, get_unique_identifier (do_read ? "RDTEXT" : "WRTEXT"),
3024 iolisttype);
3025
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. */
3032 push_temp_slots ();
3033 push_temp_slots ();
3034 *iolist_rtx = assign_temp (TREE_TYPE (iolist), 0, 1, 0);
3035 DECL_RTL (iolist) = *iolist_rtx;
3036
3037 /* process the exprlist */
3038 idxcnt = 1;
3039 while (exprlist != NULL_TREE)
3040 {
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);
3046 tree item_type;
3047 tree range_low = NULL_TREE, range_high = NULL_TREE;
3048 int have_range = 0;
3049 tree item_addr = null_pointer_node;
3050 int referable = 0;
3051 int readonly = 0;
3052
3053 /* next value in exprlist */
3054 exprlist = TREE_CHAIN (exprlist);
3055 if (item == NULL_TREE || TREE_CODE (item) == ERROR_MARK)
3056 continue;
3057
3058 item_type = TREE_TYPE (item);
3059 if (item_type == NULL_TREE)
3060 {
3061 if (TREE_CODE (item) == COND_EXPR || TREE_CODE (item) == CASE_EXPR)
3062 error ("conditional expression not allowed in this context");
3063 else
3064 error ("untyped expression as argument %d", idxcnt + 1 + argoffset);
3065 continue;
3066 }
3067 else if (TREE_CODE (item_type) == ERROR_MARK)
3068 continue;
3069
3070 if (TREE_CODE (item_type) == REFERENCE_TYPE)
3071 {
3072 item_type = TREE_TYPE (item_type);
3073 item = convert (item_type, item);
3074 }
3075
3076 /* check for a range */
3077 if (TREE_CODE (item_type) == INTEGER_TYPE &&
3078 TREE_TYPE (item_type) != NULL_TREE)
3079 {
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);
3083 have_range = 1;
3084 }
3085
3086 readonly = TYPE_READONLY_PROPERTY (item_type);
3087 referable = CH_REFERABLE (item);
3088 if (referable)
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)
3092 {
3093 item_addr = null_pointer_node;
3094 referable = 0;
3095 }
3096
3097 /* process different types */
3098 if (TREE_CODE (item_type) == INTEGER_TYPE)
3099 {
3100 int type_size = TREE_INT_CST_LOW (TYPE_SIZE (item_type));
3101 tree to_assign = NULL_TREE;
3102
3103 if (do_read && referable)
3104 {
3105 /* process an integer in case of READTEXT and expression is
3106 referable and not READONLY */
3107 to_assign = item_addr;
3108 if (have_range)
3109 {
3110 /* do it for a range */
3111 tree t, __forxx, __ptr, __low, __high;
3112 tree what_upper, what_lower;
3113
3114 /* determine the name in the union of lower and upper */
3115 if (TREE_UNSIGNED (item_type))
3116 fieldname = "_ulong";
3117 else
3118 fieldname = "_slong";
3119
3120 switch (type_size)
3121 {
3122 case 8:
3123 if (TREE_UNSIGNED (item_type))
3124 enumname = "__IO_UByteRangeLoc";
3125 else
3126 enumname = "__IO_ByteRangeLoc";
3127 break;
3128 case 16:
3129 if (TREE_UNSIGNED (item_type))
3130 enumname = "__IO_UIntRangeLoc";
3131 else
3132 enumname = "__IO_IntRangeLoc";
3133 break;
3134 case 32:
3135 if (TREE_UNSIGNED (item_type))
3136 enumname = "__IO_ULongRangeLoc";
3137 else
3138 enumname = "__IO_LongRangeLoc";
3139 break;
3140 default:
3141 error ("cannot process %d bits integer for READTEXT argument %d",
3142 type_size, idxcnt + 1 + argoffset);
3143 continue;
3144 }
3145
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));
3155
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);
3160 fieldname = 0;
3161 }
3162 else
3163 {
3164 /* no range */
3165 fieldname = "__locint";
3166 switch (type_size)
3167 {
3168 case 8:
3169 if (TREE_UNSIGNED (item_type))
3170 enumname = "__IO_UByteLoc";
3171 else
3172 enumname = "__IO_ByteLoc";
3173 break;
3174 case 16:
3175 if (TREE_UNSIGNED (item_type))
3176 enumname = "__IO_UIntLoc";
3177 else
3178 enumname = "__IO_IntLoc";
3179 break;
3180 case 32:
3181 if (TREE_UNSIGNED (item_type))
3182 enumname = "__IO_ULongLoc";
3183 else
3184 enumname = "__IO_LongLoc";
3185 break;
3186 default:
3187 error ("cannot process %d bits integer for READTEXT argument %d",
3188 type_size, idxcnt + 1 + argoffset);
3189 continue;
3190 }
3191 }
3192 }
3193 else
3194 {
3195 /* process an integer in case of WRITETEXT */
3196 to_assign = item;
3197 switch (type_size)
3198 {
3199 case 8:
3200 if (TREE_UNSIGNED (item_type))
3201 {
3202 enumname = "__IO_UByteVal";
3203 fieldname = "__valubyte";
3204 }
3205 else
3206 {
3207 enumname = "__IO_ByteVal";
3208 fieldname = "__valbyte";
3209 }
3210 break;
3211 case 16:
3212 if (TREE_UNSIGNED (item_type))
3213 {
3214 enumname = "__IO_UIntVal";
3215 fieldname = "__valuint";
3216 }
3217 else
3218 {
3219 enumname = "__IO_IntVal";
3220 fieldname = "__valint";
3221 }
3222 break;
3223 case 32:
3224 try_long:
3225 if (TREE_UNSIGNED (item_type))
3226 {
3227 enumname = "__IO_ULongVal";
3228 fieldname = "__valulong";
3229 }
3230 else
3231 {
3232 enumname = "__IO_LongVal";
3233 fieldname = "__vallong";
3234 }
3235 break;
3236 case 64:
3237 /* convert it back to {unsigned}long. */
3238 if (TREE_UNSIGNED (item_type))
3239 item_type = long_unsigned_type_node;
3240 else
3241 item_type = long_integer_type_node;
3242 item = convert (item_type, item);
3243 goto try_long;
3244 default:
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)
3248 {
3249 if (int_fits_type_p (item, long_integer_type_node))
3250 {
3251 item_type = long_integer_type_node;
3252 item = convert (item_type, item);
3253 goto try_long;
3254 }
3255 if (int_fits_type_p (item, long_unsigned_type_node))
3256 {
3257 item_type = long_unsigned_type_node;
3258 item = convert (item_type, item);
3259 goto try_long;
3260 }
3261 }
3262 error ("cannot process %d bits integer WRITETEXT argument %d",
3263 type_size, idxcnt + 1 + argoffset);
3264 continue;
3265 }
3266 }
3267 if (fieldname)
3268 {
3269 tree t, __forxx;
3270
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);
3275 }
3276 }
3277 else if (TREE_CODE (item_type) == CHAR_TYPE)
3278 {
3279 tree to_assign = NULL_TREE;
3280
3281 if (do_read && readonly)
3282 {
3283 error ("argument %d is READonly", idxcnt + 1 + argoffset);
3284 continue;
3285 }
3286 if (do_read)
3287 {
3288 if (! referable)
3289 {
3290 error ("argument %d must be referable", idxcnt + 1 + argoffset);
3291 continue;
3292 }
3293 if (have_range)
3294 {
3295 tree t, forxx, ptr, lower, upper;
3296
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);
3305
3306 fieldname = 0;
3307 enumname = "__IO_CharRangeLoc";
3308 }
3309 else
3310 {
3311 to_assign = item_addr;
3312 fieldname = "__locchar";
3313 enumname = "__IO_CharLoc";
3314 }
3315 }
3316 else
3317 {
3318 to_assign = item;
3319 enumname = "__IO_CharVal";
3320 fieldname = "__valchar";
3321 }
3322
3323 if (fieldname)
3324 {
3325 tree t, forxx;
3326
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);
3330 }
3331 }
3332 else if (TREE_CODE (item_type) == BOOLEAN_TYPE)
3333 {
3334 tree to_assign = NULL_TREE;
3335
3336 if (do_read && readonly)
3337 {
3338 error ("argument %d is READonly", idxcnt + 1 + argoffset);
3339 continue;
3340 }
3341 if (do_read)
3342 {
3343 if (! referable)
3344 {
3345 error ("argument %d must be referable", idxcnt + 1 + argoffset);
3346 continue;
3347 }
3348 if (have_range)
3349 {
3350 tree t, forxx, ptr, lower, upper;
3351
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);
3360
3361 fieldname = 0;
3362 enumname = "__IO_BoolRangeLoc";
3363 }
3364 else
3365 {
3366 to_assign = item_addr;
3367 fieldname = "__locbool";
3368 enumname = "__IO_BoolLoc";
3369 }
3370 }
3371 else
3372 {
3373 to_assign = item;
3374 enumname = "__IO_BoolVal";
3375 fieldname = "__valbool";
3376 }
3377 if (fieldname)
3378 {
3379 tree t, forxx;
3380
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);
3384 }
3385 }
3386 else if (TREE_CODE (item_type) == ENUMERAL_TYPE)
3387 {
3388 /* process an enum */
3389 tree table_name;
3390 tree context_of_type;
3391 tree t;
3392
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
3397 else
3398 context = DECL_CONTEXT (item)
3399 else
3400 context = DECL_CONTEXT (TYPE_NAME (item_type)) */
3401
3402 if (TYPE_NAME (item_type) == NULL_TREE)
3403 {
3404 if (TREE_CODE (item) == INTEGER_CST)
3405 context_of_type = NULL_TREE;
3406 else
3407 context_of_type = DECL_CONTEXT (item);
3408 }
3409 else
3410 context_of_type = DECL_CONTEXT (TYPE_NAME (item_type));
3411
3412 table_name = add_enum_to_list (item_type, context_of_type);
3413 t = build_component_ref (array_ref, get_identifier ("__t"));
3414
3415 if (do_read && readonly)
3416 {
3417 error ("argument %d is READonly", idxcnt + 1 + argoffset);
3418 continue;
3419 }
3420 if (do_read)
3421 {
3422 if (! referable)
3423 {
3424 error ("argument %d must be referable", idxcnt + 1 + argoffset);
3425 continue;
3426 }
3427 if (have_range)
3428 {
3429 tree forxx, ptr, len, nametable, lower, upper;
3430
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);
3442
3443 enumname = "__IO_SetRangeLoc";
3444 }
3445 else
3446 {
3447 tree forxx, ptr, len, nametable;
3448
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);
3456
3457 enumname = "__IO_SetLoc";
3458 }
3459 }
3460 else
3461 {
3462 tree forxx, value, nametable;
3463
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);
3469
3470 enumname = "__IO_SetVal";
3471 }
3472 }
3473 else if (chill_varying_string_type_p (item_type))
3474 {
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"));
3480
3481 if (do_read && readonly)
3482 {
3483 error ("argument %d is READonly", idxcnt + 1 + argoffset);
3484 continue;
3485 }
3486 if (do_read)
3487 {
3488 /* in this read case the argument must be referable */
3489 if (! referable)
3490 {
3491 error ("argument %d must be referable", idxcnt + 1 + argoffset);
3492 continue;
3493 }
3494 }
3495 else if (! referable)
3496 {
3497 /* in the write case we create a temporary if not referable */
3498 rtx t;
3499 tree loc = build_decl (VAR_DECL,
3500 get_unique_identifier ("WRTEXTVS"),
3501 item_type);
3502 t = assign_temp (item_type, 0, 1, 0);
3503 DECL_RTL (loc) = t;
3504 expand_assignment (loc, item, 0, 0);
3505 item_addr = force_addr_of (loc);
3506 item = loc;
3507 }
3508
3509 expand_assignment (string, item_addr, 0, 0);
3510 if (do_read)
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)))),
3514 0, 0);
3515 else
3516 /* we pass the actual length of the string */
3517 expand_assignment (length,
3518 build_component_ref (item, var_length_id),
3519 0, 0);
3520
3521 enumname = "__IO_CharVaryingLoc";
3522 }
3523 else if (CH_CHARS_TYPE_P (item_type))
3524 {
3525 /* fixed character string */
3526 tree the_size;
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"));
3531
3532 if (do_read && readonly)
3533 {
3534 error ("argument %d is READonly", idxcnt + 1 + argoffset);
3535 continue;
3536 }
3537 if (do_read)
3538 {
3539 /* in this read case the argument must be referable */
3540 if (! CH_REFERABLE (item))
3541 {
3542 error ("argument %d must be referable", idxcnt + 1 + argoffset);
3543 continue;
3544 }
3545 else
3546 item_addr = force_addr_of (item);
3547 the_size = size_in_bytes (item_type);
3548 enumname = "__IO_CharStrLoc";
3549 }
3550 else
3551 {
3552 if (! CH_REFERABLE (item))
3553 {
3554 /* in the write case we create a temporary if not referable */
3555 rtx t;
3556 int howmuchbytes;
3557
3558 howmuchbytes = int_size_in_bytes (item_type);
3559 if (howmuchbytes != -1)
3560 {
3561 /* fixed size */
3562 tree loc = build_decl (VAR_DECL,
3563 get_unique_identifier ("WRTEXTVS"),
3564 item_type);
3565 t = assign_temp (item_type, 0, 1, 0);
3566 DECL_RTL (loc) = t;
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";
3571 }
3572 else
3573 {
3574 tree type, string, exp, loc;
3575
3576 if ((howmuchbytes = intsize_of_charsexpr (item)) == -1)
3577 {
3578 error ("cannot process argument %d of WRITETEXT, unknown size",
3579 idxcnt + 1 + argoffset);
3580 continue;
3581 }
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"),
3587 type);
3588 t = assign_temp (type, 0, 1, 0);
3589 DECL_RTL (loc) = t;
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";
3595 }
3596 }
3597 else
3598 {
3599 item_addr = force_addr_of (item);
3600 the_size = size_in_bytes (item_type);
3601 enumname = "__IO_CharStrLoc";
3602 }
3603 }
3604
3605 expand_assignment (string, item_addr, 0, 0);
3606 expand_assignment (length, size_in_bytes (item_type), 0, 0);
3607
3608 }
3609 else if (CH_BOOLS_TYPE_P (item_type))
3610 {
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"));
3616
3617 if (do_read && readonly)
3618 {
3619 error ("argument %d is READonly", idxcnt + 1 + argoffset);
3620 continue;
3621 }
3622 if (do_read)
3623 {
3624 /* in this read case the argument must be referable */
3625 if (! referable)
3626 {
3627 error ("argument %d must be referable", idxcnt + 1 + argoffset);
3628 continue;
3629 }
3630 }
3631 else if (! referable)
3632 {
3633 /* in the write case we create a temporary if not referable */
3634 tree loc = build_decl (VAR_DECL,
3635 get_unique_identifier ("WRTEXTVS"),
3636 item_type);
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);
3640 }
3641
3642 expand_assignment (string, item_addr, 0, 0);
3643 expand_assignment (length, build_chill_length (item), 0, 0);
3644
3645 enumname = "__IO_BitStrLoc";
3646 }
3647 else if (TREE_CODE (item_type) == REAL_TYPE)
3648 {
3649 /* process a (long_)real */
3650 tree t, forxx, to_assign;
3651
3652 if (do_read && readonly)
3653 {
3654 error ("argument %d is READonly", idxcnt + 1 + argoffset);
3655 continue;
3656 }
3657 if (do_read && ! referable)
3658 {
3659 error ("argument %d must be referable", idxcnt + 1 + argoffset);
3660 continue;
3661 }
3662
3663 if (lookup_name (ridpointers[RID_FLOAT]) == TYPE_NAME (item_type))
3664 {
3665 /* we have a real */
3666 if (do_read)
3667 {
3668 enumname = "__IO_RealLoc";
3669 fieldname = "__locreal";
3670 to_assign = item_addr;
3671 }
3672 else
3673 {
3674 enumname = "__IO_RealVal";
3675 fieldname = "__valreal";
3676 to_assign = item;
3677 }
3678 }
3679 else
3680 {
3681 /* we have a long_real */
3682 if (do_read)
3683 {
3684 enumname = "__IO_LongRealLoc";
3685 fieldname = "__loclongreal";
3686 to_assign = item_addr;
3687 }
3688 else
3689 {
3690 enumname = "__IO_LongRealVal";
3691 fieldname = "__vallongreal";
3692 to_assign = item;
3693 }
3694 }
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);
3698 }
3699 #if 0
3700 /* don't process them for now */
3701 else if (TREE_CODE (item_type) == POINTER_TYPE)
3702 {
3703 /* we have a pointer */
3704 tree __t, __forxx;
3705
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";
3710 }
3711 else if (item_type == instance_type_node)
3712 {
3713 /* we have an INSTANCE */
3714 tree __t, __forxx;
3715
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";
3720 }
3721 #endif
3722 else
3723 {
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";
3728 }
3729
3730 /* do assignment of the enum */
3731 if (enumname)
3732 {
3733 tree descr = build_component_ref (array_ref,
3734 get_identifier ("__descr"));
3735 expand_assignment (descr,
3736 lookup_name (get_identifier (enumname)), 0, 0);
3737 }
3738 }
3739
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);
3743 }
3744 \f
3745 /* check the format string */
3746 #define LET 0x0001
3747 #define BIN 0x0002
3748 #define DEC 0x0004
3749 #define OCT 0x0008
3750 #define HEX 0x0010
3751 #define USC 0x0020
3752 #define BIL 0x0040
3753 #define SPC 0x0080
3754 #define SCS 0x0100
3755 #define IOC 0x0200
3756 #define EDC 0x0400
3757 #define CVC 0x0800
3758
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 )
3763 #define isUSC(c)
3764 #define isXXX(c,XXX) ( chartab[(c)] & XXX )
3765
3766 static
3767 short int chartab[256] = {
3768 0, 0, 0, 0, 0, 0, 0, 0,
3769 0, SPC, SPC, SPC, SPC, SPC, 0, 0,
3770
3771 0, 0, 0, 0, 0, 0, 0, 0,
3772 0, 0, 0, 0, 0, 0, 0, 0,
3773
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,
3779
3780 0, LET+HEX+BIL, LET+HEX+BIL+CVC, LET+HEX+BIL+CVC, LET+HEX+BIL, LET+HEX,
3781 LET+HEX+CVC, LET,
3782 LET+BIL+CVC, LET, LET, LET, LET, LET, LET, LET+CVC,
3783
3784 LET, LET, LET, LET, LET+EDC, LET, LET, LET,
3785 LET+EDC, LET, LET, SCS, 0, SCS, 0, USC,
3786
3787 0, LET+HEX, LET+HEX, LET+HEX, LET+HEX, LET+HEX, LET+HEX, LET,
3788 LET, LET, LET, LET, LET, LET, LET, LET,
3789
3790 LET, LET, LET, LET, LET, LET, LET, LET,
3791 LET, LET, LET, 0, 0, 0, 0, 0
3792 };
3793
3794 typedef enum
3795 {
3796 FormatText, FirstPercent, RepFact, ConvClause, EditClause, ClauseEnd,
3797 AfterWidth, FractWidth, FractWidthCont, ExpoWidth, ExpoWidthCont,
3798 ClauseWidth, CatchPadding, LastPercent
3799 } fcsstate_t;
3800
3801 #define CONVERSIONCODES "CHOBF"
3802 typedef enum
3803 {
3804 DefaultConv, HexConv, OctalConv, BinaryConv, ScientConv
3805 } convcode_t;
3806 static convcode_t convcode;
3807
3808 static tree check_exprlist PARAMS ((convcode_t, tree, int,
3809 unsigned long));
3810
3811 typedef enum
3812 {
3813 False, True,
3814 } Boolean;
3815
3816 static unsigned long fractionwidth;
3817
3818 #define IOCODES "/+-?!="
3819 typedef enum {
3820 NextRecord, NextPage, CurrentLine, Prompt, Emit, EndPage
3821 } iocode_t;
3822 static iocode_t iocode;
3823
3824 #define EDITCODES "X<>T"
3825 typedef enum {
3826 SpaceSkip, SkipLeft, SkipRight, Tabulation
3827 } editcode_t;
3828 static editcode_t editcode;
3829
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;
3840
3841 typedef enum {
3842 NormalEnd, EndAtParen, TextFailEnd
3843 } formatexit_t;
3844
3845 static formatexit_t scanformcont PARAMS ((char *, int, char **, int *,
3846 tree, tree *, int, int *));
3847
3848 /* NOTE: varibale have to be set to False before calling check_format_string */
3849 static Boolean empty_printed;
3850
3851 static int formstroffset;
3852
3853 static tree
3854 check_exprlist (code, exprlist, argnum, repetition)
3855 convcode_t code;
3856 tree exprlist;
3857 int argnum;
3858 unsigned long repetition;
3859 {
3860 tree expr, type, result = NULL_TREE;
3861
3862 while (repetition--)
3863 {
3864 if (exprlist == NULL_TREE)
3865 {
3866 if (empty_printed == False)
3867 {
3868 warning ("too few arguments for this format string");
3869 empty_printed = True;
3870 }
3871 return NULL_TREE;
3872 }
3873 expr = TREE_VALUE (exprlist);
3874 result = exprlist = TREE_CHAIN (exprlist);
3875 if (expr == NULL_TREE || TREE_CODE (expr) == ERROR_MARK)
3876 return result;
3877 type = TREE_TYPE (expr);
3878 if (type == NULL_TREE || TREE_CODE (type) == ERROR_MARK)
3879 return result;
3880 if (TREE_CODE (type) == REFERENCE_TYPE)
3881 type = TREE_TYPE (type);
3882 if (type == NULL_TREE || TREE_CODE (type) == ERROR_MARK)
3883 return result;
3884
3885 switch (code)
3886 {
3887 case DefaultConv:
3888 /* %C, everything is allowed. Not know types are flaged later. */
3889 break;
3890 case ScientConv:
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);
3895 break;
3896 case HexConv:
3897 case OctalConv:
3898 case BinaryConv:
3899 case -1:
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);
3904 break;
3905 default:
3906 /* there is an invalid conversion code */
3907 break;
3908 }
3909 }
3910 return result;
3911 }
3912
3913 static formatexit_t
3914 scanformcont (fcs, len, fcsptr, lenptr, exprlist, exprptr,
3915 firstargnum, nextargnum)
3916 char *fcs;
3917 int len;
3918 char **fcsptr;
3919 int *lenptr;
3920 tree exprlist;
3921 tree *exprptr;
3922 int firstargnum;
3923 int *nextargnum;
3924 {
3925 fcsstate_t state = FormatText;
3926 unsigned char curr;
3927 int dig;
3928
3929 while (len--)
3930 {
3931 curr = *fcs++;
3932 formstroffset++;
3933 switch (state)
3934 {
3935 case FormatText:
3936 if (curr == '%')
3937 state = FirstPercent;
3938 break;
3939
3940 after_first_percent: ;
3941 case FirstPercent:
3942 if (curr == '%')
3943 {
3944 state = FormatText;
3945 break;
3946 }
3947 if (curr == ')')
3948 {
3949 *lenptr = len;
3950 *fcsptr = fcs;
3951 *exprptr = exprlist;
3952 *nextargnum = firstargnum;
3953 return EndAtParen;
3954 }
3955 if (isDEC (curr))
3956 {
3957 state = RepFact;
3958 repetition = curr - '0';
3959 break;
3960 }
3961
3962 repetition = 1;
3963
3964 test_for_control_codes: ;
3965 if (isCVC (curr))
3966 {
3967 state = ConvClause;
3968 convcode = strchr (CONVERSIONCODES, curr) - CONVERSIONCODES;
3969 leftadjust = False;
3970 overflowev = False;
3971 dynamicwid = False;
3972 paddingdef = False;
3973 paddingchar = ' ';
3974 fractiondef = False;
3975 /* fractionwidth = 0; default depends on mode ! */
3976 exponentdef = False;
3977 exponentwidth = 3;
3978 clausewidth = 0;
3979 /* check the argument */
3980 exprlist = check_exprlist (convcode, exprlist, firstargnum, repetition);
3981 firstargnum++;
3982 break;
3983 }
3984 if (isEDC (curr))
3985 {
3986 state = EditClause;
3987 editcode = strchr (EDITCODES, curr) - EDITCODES;
3988 dynamicwid = False;
3989 clausewidth = editcode == Tabulation ? 0 : 1;
3990 break;
3991 }
3992 if (isIOC (curr))
3993 {
3994 state = ClauseEnd;
3995 iocode = strchr (IOCODES, curr) - IOCODES;
3996 break;
3997 }
3998 if (curr == '(')
3999 {
4000 unsigned long times = repetition;
4001 int cntlen;
4002 char* cntfcs;
4003 tree cntexprlist;
4004 int nextarg;
4005
4006 while (times--)
4007 {
4008 if (scanformcont (fcs, len, &cntfcs, &cntlen,
4009 exprlist, &cntexprlist,
4010 firstargnum, &nextarg) != EndAtParen )
4011 {
4012 warning ("unmatched open paren");
4013 break;
4014 }
4015 exprlist = cntexprlist;
4016 }
4017 fcs = cntfcs;
4018 len = cntlen;
4019 if (len < 0)
4020 len = 0;
4021 exprlist = cntexprlist;
4022 firstargnum = nextarg;
4023 state = FormatText;
4024 break;
4025 }
4026 warning ("bad format specification character (offset %d)", formstroffset);
4027 state = FormatText;
4028 /* skip one argument */
4029 if (exprlist != NULL_TREE)
4030 exprlist = TREE_CHAIN (exprlist);
4031 break;
4032
4033 case RepFact:
4034 if (isDEC (curr))
4035 {
4036 dig = curr - '0';
4037 if (repetition > (ULONG_MAX - dig)/10)
4038 {
4039 warning ("repetition factor overflow (offset %d)", formstroffset);
4040 return TextFailEnd;
4041 }
4042 repetition = repetition*10 + dig;
4043 break;
4044 }
4045 goto test_for_control_codes;
4046
4047 case ConvClause:
4048 if (isDEC (curr))
4049 {
4050 state = ClauseWidth;
4051 clausewidth = curr - '0';
4052 break;
4053 }
4054 if (curr == 'L')
4055 {
4056 if (leftadjust)
4057 warning ("duplicate qualifier (offset %d)", formstroffset);
4058 leftadjust = True;
4059 break;
4060 }
4061 if (curr == 'E')
4062 {
4063 if (overflowev)
4064 warning ("duplicate qualifier (offset %d)", formstroffset);
4065 overflowev = True;
4066 break;
4067 }
4068 if (curr == 'P')
4069 {
4070 if (paddingdef)
4071 warning ("duplicate qualifier (offset %d)", formstroffset);
4072 paddingdef = True;
4073 state = CatchPadding;
4074 break;
4075 }
4076
4077 test_for_variable_width: ;
4078 if (curr == 'V')
4079 {
4080 dynamicwid = True;
4081 state = AfterWidth;
4082 exprlist = check_exprlist (-1, exprlist, firstargnum, 1);
4083 firstargnum++;
4084 break;
4085 }
4086 goto test_for_fraction_width;
4087
4088 case ClauseWidth:
4089 if (isDEC (curr))
4090 {
4091 dig = curr - '0';
4092 if (clausewidth > (ULONG_MAX - dig)/10)
4093 warning ("clause width overflow (offset %d)", formstroffset);
4094 else
4095 clausewidth = clausewidth*10 + dig;
4096 break;
4097 }
4098 /* fall through */
4099
4100 test_for_fraction_width: ;
4101 case AfterWidth:
4102 if (curr == '.')
4103 {
4104 if (convcode != DefaultConv && convcode != ScientConv)
4105 {
4106 warning ("no fraction (offset %d)", formstroffset);
4107 state = FormatText;
4108 break;
4109 }
4110 fractiondef = True;
4111 state = FractWidth;
4112 break;
4113 }
4114 goto test_for_exponent_width;
4115
4116 case FractWidth:
4117 if (isDEC (curr))
4118 {
4119 state = FractWidthCont;
4120 fractionwidth = curr - '0';
4121 break;
4122 }
4123 else
4124 warning ("no fraction width (offset %d)", formstroffset);
4125
4126 case FractWidthCont:
4127 if (isDEC (curr))
4128 {
4129 dig = curr - '0';
4130 if (fractionwidth > (ULONG_MAX - dig)/10)
4131 warning ("fraction width overflow (offset %d)", formstroffset);
4132 else
4133 fractionwidth = fractionwidth*10 + dig;
4134 break;
4135 }
4136
4137 test_for_exponent_width: ;
4138 if (curr == ':')
4139 {
4140 if (convcode != ScientConv)
4141 {
4142 warning ("no exponent (offset %d)", formstroffset);
4143 state = FormatText;
4144 break;
4145 }
4146 exponentdef = True;
4147 state = ExpoWidth;
4148 break;
4149 }
4150 goto test_for_final_percent;
4151
4152 case ExpoWidth:
4153 if (isDEC (curr))
4154 {
4155 state = ExpoWidthCont;
4156 exponentwidth = curr - '0';
4157 break;
4158 }
4159 else
4160 warning ("no exponent width (offset %d)", formstroffset);
4161
4162 case ExpoWidthCont:
4163 if (isDEC (curr))
4164 {
4165 dig = curr - '0';
4166 if (exponentwidth > (ULONG_MAX - dig)/10)
4167 warning ("exponent width overflow (offset %d)", formstroffset);
4168 else
4169 exponentwidth = exponentwidth*10 + dig;
4170 break;
4171 }
4172 /* fall through */
4173
4174 test_for_final_percent: ;
4175 case ClauseEnd:
4176 if (curr == '%')
4177 {
4178 state = LastPercent;
4179 break;
4180 }
4181
4182 state = FormatText;
4183 break;
4184
4185 case CatchPadding:
4186 paddingchar = curr;
4187 state = ConvClause;
4188 break;
4189
4190 case EditClause:
4191 if (isDEC (curr))
4192 {
4193 state = ClauseWidth;
4194 clausewidth = curr - '0';
4195 break;
4196 }
4197 goto test_for_variable_width;
4198
4199 case LastPercent:
4200 if (curr == '.')
4201 {
4202 state = FormatText;
4203 break;
4204 }
4205 goto after_first_percent;
4206
4207 default:
4208 error ("internal error in check_format_string");
4209 }
4210 }
4211
4212 switch (state)
4213 {
4214 case FormatText:
4215 break;
4216 case FirstPercent:
4217 case LastPercent:
4218 case RepFact:
4219 case FractWidth:
4220 case ExpoWidth:
4221 warning ("bad format specification character (offset %d)", formstroffset);
4222 break;
4223 case CatchPadding:
4224 warning ("no padding character (offset %d)", formstroffset);
4225 break;
4226 default:
4227 break;
4228 }
4229 *fcsptr = fcs;
4230 *lenptr = len;
4231 *exprptr = exprlist;
4232 *nextargnum = firstargnum;
4233 return NormalEnd;
4234 }
4235 static void
4236 check_format_string (format_str, exprlist, firstargnum)
4237 tree format_str;
4238 tree exprlist;
4239 int firstargnum;
4240 {
4241 char *x;
4242 int y, yy;
4243 tree z = NULL_TREE;
4244
4245 if (TREE_CODE (format_str) != STRING_CST)
4246 /* do nothing if we don't have a string constant */
4247 return;
4248
4249 formstroffset = -1;
4250 scanformcont (TREE_STRING_POINTER (format_str),
4251 TREE_STRING_LENGTH (format_str), &x, &y,
4252 exprlist, &z,
4253 firstargnum, &yy);
4254 if (z != NULL_TREE)
4255 /* too may arguments for format string */
4256 warning ("too many arguments for this format string");
4257 }
4258 \f
4259 static int
4260 get_max_size (expr)
4261 tree expr;
4262 {
4263 if (TREE_CODE (expr) == INDIRECT_REF)
4264 {
4265 tree x = TREE_OPERAND (expr, 0);
4266 tree y = TREE_OPERAND (x, 0);
4267 return int_size_in_bytes (TREE_TYPE (y));
4268 }
4269 else if (TREE_CODE (expr) == CONCAT_EXPR)
4270 return intsize_of_charsexpr (expr);
4271 else
4272 return int_size_in_bytes (TREE_TYPE (expr));
4273 }
4274
4275 static int
4276 intsize_of_charsexpr (expr)
4277 tree expr;
4278 {
4279 int op0size, op1size;
4280
4281 if (TREE_CODE (expr) != CONCAT_EXPR)
4282 return -1;
4283
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)
4288 return -1;
4289 return op0size + op1size;
4290 }
4291
4292 tree
4293 build_chill_writetext (text_arg, exprlist)
4294 tree text_arg, exprlist;
4295 {
4296 tree iolist_addr = null_pointer_node;
4297 tree iolist_length = integer_zero_node;
4298 tree fstr_addr;
4299 tree fstr_length;
4300 tree outstr_addr;
4301 tree outstr_length;
4302 tree fstrtype;
4303 tree outfunction;
4304 tree filename, linenumber;
4305 tree format_str = NULL_TREE, indexexpr = NULL_TREE;
4306 rtx iolist_rtx = NULL_RTX;
4307 int argoffset = 0;
4308
4309 /* make some checks */
4310 if (text_arg == NULL_TREE || TREE_CODE (text_arg) == ERROR_MARK)
4311 return error_mark_node;
4312
4313 if (exprlist != NULL_TREE)
4314 {
4315 if (TREE_CODE (exprlist) != TREE_LIST)
4316 return error_mark_node;
4317 }
4318
4319 /* check the text argument */
4320 if (chill_varying_string_type_p (TREE_TYPE (text_arg)))
4321 {
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);
4328 }
4329 else if (CH_IS_TEXT_MODE (TREE_TYPE (text_arg)))
4330 {
4331 /* we have a text mode */
4332 tree indexmode;
4333
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)
4338 {
4339 /* no index */
4340 format_str = TREE_VALUE (exprlist);
4341 exprlist = TREE_CHAIN (exprlist);
4342 }
4343 else
4344 {
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))
4349 {
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");
4355 else
4356 error ("incompatible index mode");
4357 return error_mark_node;
4358 }
4359 if (exprlist == NULL_TREE)
4360 {
4361 error ("too few arguments in call to `writetext'");
4362 return error_mark_node;
4363 }
4364 format_str = TREE_VALUE (exprlist);
4365 exprlist = TREE_CHAIN (exprlist);
4366 argoffset = 1;
4367 }
4368 outstr_addr = force_addr_of (text_arg);
4369 outstr_length = convert (integer_type_node, indexexpr);
4370 outfunction = lookup_name (get_identifier ("__writetext_f"));
4371 }
4372 else
4373 {
4374 error ("argument 1 for WRITETEXT must be a TEXT or CHARS(n) VARYING location");
4375 return error_mark_node;
4376 }
4377
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))
4383 {
4384 /* we have a character string */
4385 fstr_addr = force_addr_of (format_str);
4386 fstr_length = size_in_bytes (fstrtype);
4387 }
4388 else if (chill_varying_string_type_p (TREE_TYPE (format_str)))
4389 {
4390 /* we have a varying char string */
4391 fstr_addr
4392 = force_addr_of (build_component_ref (format_str, var_data_id));
4393 fstr_length = build_component_ref (format_str, var_length_id);
4394 }
4395 else
4396 {
4397 error ("`format string' for WRITETEXT must be a CHARACTER string");
4398 return error_mark_node;
4399 }
4400
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);
4404
4405 /* tree to call the function */
4406
4407 filename = force_addr_of (get_chill_filename ());
4408 linenumber = get_chill_linenumber ();
4409
4410 expand_expr_stmt (
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))))))))));
4421
4422 /* get rid of the iolist variable, if we have one */
4423 if (iolist_rtx != NULL_RTX)
4424 {
4425 free_temp_slots ();
4426 pop_temp_slots ();
4427 free_temp_slots ();
4428 pop_temp_slots ();
4429 }
4430
4431 /* return something the rest of the machinery can work with,
4432 i.e. (void)0 */
4433 return build1 (CONVERT_EXPR, void_type_node, integer_zero_node);
4434 }
4435
4436 tree
4437 build_chill_readtext (text_arg, exprlist)
4438 tree text_arg, exprlist;
4439 {
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;
4447 int argoffset = 0;
4448
4449 /* make some checks */
4450 if (text_arg == NULL_TREE || TREE_CODE (text_arg) == ERROR_MARK)
4451 return error_mark_node;
4452
4453 if (exprlist != NULL_TREE)
4454 {
4455 if (TREE_CODE (exprlist) != TREE_LIST)
4456 return error_mark_node;
4457 }
4458
4459 /* check the text argument */
4460 if (CH_CHARS_TYPE_P (TREE_TYPE (text_arg)))
4461 {
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);
4467 }
4468 else if (chill_varying_string_type_p (TREE_TYPE (text_arg)))
4469 {
4470 instr_addr
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);
4476 }
4477 else if (CH_IS_TEXT_MODE (TREE_TYPE (text_arg)))
4478 {
4479 /* we have a text mode */
4480 tree indexmode;
4481
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)
4486 {
4487 /* no index */
4488 format_str = TREE_VALUE (exprlist);
4489 exprlist = TREE_CHAIN (exprlist);
4490 }
4491 else
4492 {
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))
4497 {
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");
4503 else
4504 error ("incompatible index mode");
4505 return error_mark_node;
4506 }
4507 if (exprlist == NULL_TREE)
4508 {
4509 error ("too few arguments in call to `readtext'");
4510 return error_mark_node;
4511 }
4512 format_str = TREE_VALUE (exprlist);
4513 exprlist = TREE_CHAIN (exprlist);
4514 argoffset = 1;
4515 }
4516 instr_addr = force_addr_of (text_arg);
4517 instr_length = convert (integer_type_node, indexexpr);
4518 infunction = lookup_name (get_identifier ("__readtext_f"));
4519 }
4520 else
4521 {
4522 error ("argument 1 for READTEXT must be a TEXT location or CHARS(n) [ VARYING ] expression");
4523 return error_mark_node;
4524 }
4525
4526 /* check the format string */
4527 fstrtype = TREE_TYPE (format_str);
4528 if (CH_CHARS_TYPE_P (fstrtype))
4529 {
4530 /* we have a character string */
4531 fstr_addr = force_addr_of (format_str);
4532 fstr_length = size_in_bytes (fstrtype);
4533 }
4534 else if (chill_varying_string_type_p (fstrtype))
4535 {
4536 /* we have a CHARS(n) VARYING */
4537 fstr_addr
4538 = force_addr_of (build_component_ref (format_str, var_data_id));
4539 fstr_length = build_component_ref (format_str, var_length_id);
4540 }
4541 else
4542 {
4543 error ("`format string' for READTEXT must be a CHARACTER string");
4544 return error_mark_node;
4545 }
4546
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);
4550
4551 /* build the function call */
4552 filename = force_addr_of (get_chill_filename ());
4553 linenumber = get_chill_linenumber ();
4554 expand_expr_stmt (
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))))))))));
4565
4566 /* get rid of the iolist variable, if we have one */
4567 if (iolist_rtx != NULL_RTX)
4568 {
4569 free_temp_slots ();
4570 pop_temp_slots ();
4571 free_temp_slots ();
4572 pop_temp_slots ();
4573 }
4574
4575 /* return something the rest of the machinery can work with,
4576 i.e. (void)0 */
4577 return build1 (CONVERT_EXPR, void_type_node, integer_zero_node);
4578 }
4579
4580 /* this function build all necessary enum-tables used for
4581 WRITETEXT or READTEXT of an enum */
4582
4583 void build_enum_tables ()
4584 {
4585 SAVE_ENUM_NAMES *names;
4586 SAVE_ENUMS *wrk;
4587 void *saveptr;
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;
4592
4593 if (pass == 1)
4594 return;
4595
4596 save_maximum_field_alignment = maximum_field_alignment;
4597 maximum_field_alignment = 0;
4598
4599 /* output all names */
4600 names = used_enum_names;
4601
4602 while (names != (SAVE_ENUM_NAMES *)0)
4603 {
4604 tree var = get_unique_identifier ("ENUMNAME");
4605 tree type;
4606
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)),
4612 0, 0);
4613 names = names->forward;
4614 }
4615
4616 /* output the tables and pointers to tables */
4617 wrk = used_enums;
4618 while (wrk != (SAVE_ENUMS *)0)
4619 {
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;
4625 int i;
4626
4627 vals = wrk->vals;
4628 for (i = 0; i < wrk->num_vals; i++)
4629 {
4630 tree decl = vals->name->decl;
4631 addr = build1 (ADDR_EXPR,
4632 build_pointer_type (char_type_node),
4633 decl);
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);
4639 vals++;
4640 }
4641
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;
4650
4651 /* generate table */
4652 idxlist = build_tree_list (NULL_TREE,
4653 build_chill_range_type (NULL_TREE,
4654 integer_zero_node,
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,
4659 1, init, 0, 0);
4660 table_addr = build1 (ADDR_EXPR,
4661 build_pointer_type (TREE_TYPE (enum_table_type)),
4662 table);
4663 TREE_CONSTANT (table_addr) = 1;
4664
4665 /* generate pointer to table */
4666 decl_temp1 (DECL_NAME (varptr), TREE_TYPE (table_addr),
4667 1, table_addr, 0, 0);
4668
4669 /* free that stuff */
4670 saveptr = wrk->forward;
4671
4672 free (wrk->vals);
4673 free (wrk);
4674
4675 /* next enum */
4676 wrk = saveptr;
4677 }
4678
4679 /* free all the names */
4680 names = used_enum_names;
4681 while (names != (SAVE_ENUM_NAMES *)0)
4682 {
4683 saveptr = names->forward;
4684 free (names);
4685 names = saveptr;
4686 }
4687
4688 used_enums = (SAVE_ENUMS *)0;
4689 used_enum_names = (SAVE_ENUM_NAMES *)0;
4690 maximum_field_alignment = save_maximum_field_alignment;
4691 }
Mirror of the offical gcc git repository hosted at gcc.gnu.org