?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
From Phil Blundell:
[official-gcc.git] / gcc / ch / inout.c
blobbac22b412508ef326ddb5e8c9ea2b670a2d351c9
1 /* Implement I/O-related actions for CHILL.
2 Copyright (C) 1992, 93, 1994, 1998, 1999 Free Software Foundation, Inc.
3
4 This file is part of GNU CC.
5
6 GNU CC is free software; you can redistribute it and/or modify
7 it under the terms of the GNU General Public License as published by
8 the Free Software Foundation; either version 2, or (at your option)
9 any later version.
10
11 GNU CC is distributed in the hope that it will be useful,
12 but WITHOUT ANY WARRANTY; without even the implied warranty of
13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 GNU General Public License for more details.
15
16 You should have received a copy of the GNU General Public License
17 along with GNU CC; see the file COPYING. If not, write to
18 the Free Software Foundation, 59 Temple Place - Suite 330,
19 Boston, MA 02111-1307, USA. */
20
21 #include "config.h"
22 #include "system.h"
23 #include "tree.h"
24 #include "ch-tree.h"
25 #include "rtl.h"
26 #include "lex.h"
27 #include "flags.h"
28 #include "input.h"
29 #include "assert.h"
30 #include "toplev.h"
31
32 /* set non-zero if input text is forced to lowercase */
33 extern int ignore_case;
34
35 /* set non-zero if special words are to be entered in uppercase */
36 extern int special_UC;
37
38 static int intsize_of_charsexpr PROTO((tree));
39
40 /* association mode */
41 tree association_type_node;
42 /* initialzier for association mode */
43 tree association_init_value;
44
45 /* NOTE: should be same as in runtime/chillrt0.c */
46 #define STDIO_TEXT_LENGTH 1024
47 /* mode of stdout, stdin, stderr*/
48 static tree stdio_type_node;
49
50 /* usage- and where modes */
51 tree usage_type_node;
52 tree where_type_node;
53
54 /* we have to distinguish between io-list-type for WRITETEXT
55 and for READTEXT. WRITETEXT does not process ranges and
56 READTEXT must get pointers to the variables.
57 */
58 /* variable to hold the type of the io_list */
59 static tree chill_io_list_type = NULL_TREE;
60
61 /* the type for the enum tables */
62 static tree enum_table_type = NULL_TREE;
63
64 /* structure to save enums for later use in compilation */
65 typedef struct save_enum_names
66 {
67 struct save_enum_names *forward;
68 tree name;
69 tree decl;
70 } SAVE_ENUM_NAMES;
71
72 static SAVE_ENUM_NAMES *used_enum_names = (SAVE_ENUM_NAMES *)0;
73
74 typedef struct save_enum_values
75 {
76 long val;
77 struct save_enum_names *name;
78 } SAVE_ENUM_VALUES;
79
80 typedef struct save_enums
81 {
82 struct save_enums *forward;
83 tree context;
84 tree type;
85 tree ptrdecl;
86 long num_vals;
87 struct save_enum_values *vals;
88 } SAVE_ENUMS;
89
90 static SAVE_ENUMS *used_enums = (SAVE_ENUMS *)0;
91
92 \f
93 /* Function collects all enums are necessary to collect, makes a copy of
94 the value and returns a VAR_DECL external to current function describing
95 the pointer to a name table, which will be generated at the end of
96 compilation
97 */
98
99 static tree add_enum_to_list (type, context)
100 tree type;
101 tree context;
102 {
103 tree tmp;
104 SAVE_ENUMS *wrk = used_enums;
105 SAVE_ENUM_VALUES *vals;
106 SAVE_ENUM_NAMES *names;
107
108 while (wrk != (SAVE_ENUMS *)0)
109 {
110 /* search for this enum already in use */
111 if (wrk->context == context && wrk->type == type)
112 {
113 /* yes, found. look if the ptrdecl is valid in this scope */
114 char *name = IDENTIFIER_POINTER (DECL_NAME (wrk->ptrdecl));
115 tree var = get_identifier (name);
116 tree decl = lookup_name (var);
117
118 if (decl == NULL_TREE)
119 {
120 /* no, not valid in this context, declare it */
121 decl = decl_temp1 (var, build_pointer_type (TREE_TYPE (enum_table_type)),
122 0, NULL_TREE, 1, 0);
123 }
124 return decl;
125 }
126
127 /* next one */
128 wrk = wrk->forward;
129 }
130
131 /* not yet found -- generate an entry */
132 wrk = (SAVE_ENUMS *)xmalloc (sizeof (SAVE_ENUMS));
133 wrk->forward = used_enums;
134 used_enums = wrk;
135
136 /* generate the pointer decl */
137 wrk->ptrdecl = get_unique_identifier ("ENUMTABPTR");
138 wrk->ptrdecl = decl_temp1 (wrk->ptrdecl, build_pointer_type (TREE_TYPE (enum_table_type)),
139 0, NULL_TREE, 1, 0);
140
141 /* save information for later use */
142 wrk->context = context;
143 wrk->type = type;
144
145 /* insert the names and values */
146 tmp = TYPE_FIELDS (type);
147 wrk->num_vals = list_length (tmp);
148 vals = (SAVE_ENUM_VALUES *)xmalloc (sizeof (SAVE_ENUM_VALUES) * wrk->num_vals);
149 wrk->vals = vals;
150
151 while (tmp != NULL_TREE)
152 {
153 /* search if name is already in use */
154 names = used_enum_names;
155 while (names != (SAVE_ENUM_NAMES *)0)
156 {
157 if (names->name == TREE_PURPOSE (tmp))
158 break;
159 names = names->forward;
160 }
161 if (names == (SAVE_ENUM_NAMES *)0)
162 {
163 /* we have to insert one */
164 names = (SAVE_ENUM_NAMES *)xmalloc (sizeof (SAVE_ENUM_NAMES));
165 names->forward = used_enum_names;
166 used_enum_names = names;
167 names->decl = NULL_TREE;
168 names->name = TREE_PURPOSE (tmp);
169 }
170 vals->name = names;
171 vals->val = TREE_INT_CST_LOW (TREE_VALUE (tmp));
172
173 /* next entry in enum */
174 vals++;
175 tmp = TREE_CHAIN (tmp);
176 }
177
178 /* return the generated decl */
179 return wrk->ptrdecl;
180 }
181
182 \f
183 static void
184 build_chill_io_list_type ()
185 {
186 tree list = NULL_TREE;
187 tree result, enum1, listbase;
188 tree io_descriptor;
189 tree decl1, decl2;
190 tree forcharstring, forset_W, forset_R, forboolrange;
191
192 tree forintrange, intunion, forsetrange, forcharrange;
193 tree long_type, ulong_type, union_type;
194
195 long_type = long_integer_type_node;
196 ulong_type = long_unsigned_type_node;
197
198 if (chill_io_list_type != NULL_TREE)
199 /* already done */
200 return;
201
202 /* first build the enum for the desriptor */
203 enum1 = start_enum (NULL_TREE);
204 result = build_enumerator (get_identifier ("__IO_UNUSED"),
205 NULL_TREE);
206 list = chainon (result, list);
207
208 result = build_enumerator (get_identifier ("__IO_ByteVal"),
209 NULL_TREE);
210 list = chainon (result, list);
211
212 result = build_enumerator (get_identifier ("__IO_UByteVal"),
213 NULL_TREE);
214 list = chainon (result, list);
215
216 result = build_enumerator (get_identifier ("__IO_IntVal"),
217 NULL_TREE);
218 list = chainon (result, list);
219
220 result = build_enumerator (get_identifier ("__IO_UIntVal"),
221 NULL_TREE);
222 list = chainon (result, list);
223
224 result = build_enumerator (get_identifier ("__IO_LongVal"),
225 NULL_TREE);
226 list = chainon (result, list);
227
228 result = build_enumerator (get_identifier ("__IO_ULongVal"),
229 NULL_TREE);
230 list = chainon (result, list);
231
232 result = build_enumerator (get_identifier ("__IO_ByteLoc"),
233 NULL_TREE);
234 list = chainon (result, list);
235
236 result = build_enumerator (get_identifier ("__IO_UByteLoc"),
237 NULL_TREE);
238 list = chainon (result, list);
239
240 result = build_enumerator (get_identifier ("__IO_IntLoc"),
241 NULL_TREE);
242 list = chainon (result, list);
243
244 result = build_enumerator (get_identifier ("__IO_UIntLoc"),
245 NULL_TREE);
246 list = chainon (result, list);
247
248 result = build_enumerator (get_identifier ("__IO_LongLoc"),
249 NULL_TREE);
250 list = chainon (result, list);
251
252 result = build_enumerator (get_identifier ("__IO_ULongLoc"),
253 NULL_TREE);
254 list = chainon (result, list);
255
256 result = build_enumerator (get_identifier ("__IO_ByteRangeLoc"),
257 NULL_TREE);
258 list = chainon (result, list);
259
260 result = build_enumerator (get_identifier ("__IO_UByteRangeLoc"),
261 NULL_TREE);
262 list = chainon (result, list);
263
264 result = build_enumerator (get_identifier ("__IO_IntRangeLoc"),
265 NULL_TREE);
266 list = chainon (result, list);
267
268 result = build_enumerator (get_identifier ("__IO_UIntRangeLoc"),
269 NULL_TREE);
270 list = chainon (result, list);
271
272 result = build_enumerator (get_identifier ("__IO_LongRangeLoc"),
273 NULL_TREE);
274 list = chainon (result, list);
275
276 result = build_enumerator (get_identifier ("__IO_ULongRangeLoc"),
277 NULL_TREE);
278 list = chainon (result, list);
279
280 result = build_enumerator (get_identifier ("__IO_BoolVal"),
281 NULL_TREE);
282 list = chainon (result, list);
283
284 result = build_enumerator (get_identifier ("__IO_BoolLoc"),
285 NULL_TREE);
286 list = chainon (result, list);
287
288 result = build_enumerator (get_identifier ("__IO_BoolRangeLoc"),
289 NULL_TREE);
290 list = chainon (result, list);
291
292 result = build_enumerator (get_identifier ("__IO_SetVal"),
293 NULL_TREE);
294 list = chainon (result, list);
295
296 result = build_enumerator (get_identifier ("__IO_SetLoc"),
297 NULL_TREE);
298 list = chainon (result, list);
299
300 result = build_enumerator (get_identifier ("__IO_SetRangeLoc"),
301 NULL_TREE);
302 list = chainon (result, list);
303
304 result = build_enumerator (get_identifier ("__IO_CharVal"),
305 NULL_TREE);
306 list = chainon (result, list);
307
308 result = build_enumerator (get_identifier ("__IO_CharLoc"),
309 NULL_TREE);
310 list = chainon (result, list);
311
312 result = build_enumerator (get_identifier ("__IO_CharRangeLoc"),
313 NULL_TREE);
314 list = chainon (result, list);
315
316 result = build_enumerator (get_identifier ("__IO_CharStrLoc"),
317 NULL_TREE);
318 list = chainon (result, list);
319
320 result = build_enumerator (get_identifier ("__IO_CharVaryingLoc"),
321 NULL_TREE);
322 list = chainon (result, list);
323
324 result = build_enumerator (get_identifier ("__IO_BitStrLoc"),
325 NULL_TREE);
326 list = chainon (result, list);
327
328 result = build_enumerator (get_identifier ("__IO_RealVal"),
329 NULL_TREE);
330 list = chainon (result, list);
331
332 result = build_enumerator (get_identifier ("__IO_RealLoc"),
333 NULL_TREE);
334 list = chainon (result, list);
335
336 result = build_enumerator (get_identifier ("__IO_LongRealVal"),
337 NULL_TREE);
338 list = chainon (result, list);
339
340 result = build_enumerator (get_identifier ("__IO_LongRealLoc"),
341 NULL_TREE);
342 list = chainon (result, list);
343 #if 0
344 result = build_enumerator (get_identifier ("_IO_Pointer"),
345 NULL_TREE);
346 list = chainon (result, list);
347 #endif
348
349 result = finish_enum (enum1, list);
350 pushdecl (io_descriptor = build_decl (TYPE_DECL,
351 get_identifier ("__tmp_IO_enum"),
352 result));
353 /* prevent seizing/granting of the decl */
354 DECL_SOURCE_LINE (io_descriptor) = 0;
355 satisfy_decl (io_descriptor, 0);
356
357 /* build type for enum_tables */
358 decl1 = build_decl (FIELD_DECL, get_identifier ("value"),
359 long_type);
360 DECL_INITIAL (decl1) = NULL_TREE;
361 decl2 = build_decl (FIELD_DECL, get_identifier ("name"),
362 build_pointer_type (char_type_node));
363 DECL_INITIAL (decl2) = NULL_TREE;
364 TREE_CHAIN (decl1) = decl2;
365 TREE_CHAIN (decl2) = NULL_TREE;
366 result = build_chill_struct_type (decl1);
367 pushdecl (enum_table_type = build_decl (TYPE_DECL,
368 get_identifier ("__tmp_IO_enum_table_type"),
369 result));
370 DECL_SOURCE_LINE (enum_table_type) = 0;
371 satisfy_decl (enum_table_type, 0);
372
373 /* build type for writing a set mode */
374 decl1 = build_decl (FIELD_DECL, get_identifier ("value"),
375 long_type);
376 DECL_INITIAL (decl1) = NULL_TREE;
377 listbase = decl1;
378
379 decl2 = build_decl (FIELD_DECL, get_identifier ("name_table"),
380 build_pointer_type (TREE_TYPE (enum_table_type)));
381 DECL_INITIAL (decl2) = NULL_TREE;
382 TREE_CHAIN (decl1) = decl2;
383 decl1 = decl2;
384 TREE_CHAIN (decl2) = NULL_TREE;
385
386 result = build_chill_struct_type (listbase);
387 pushdecl (forset_W = build_decl (TYPE_DECL,
388 get_identifier ("__tmp_WIO_set"),
389 result));
390 DECL_SOURCE_LINE (forset_W) = 0;
391 satisfy_decl (forset_W, 0);
392
393 /* build type for charrange */
394 decl1 = build_decl (FIELD_DECL, get_identifier ("ptr"),
395 build_pointer_type (char_type_node));
396 DECL_INITIAL (decl1) = NULL_TREE;
397 listbase = decl1;
398
399 decl2 = build_decl (FIELD_DECL, get_identifier ("lower"),
400 long_type);
401 DECL_INITIAL (decl2) = NULL_TREE;
402 TREE_CHAIN (decl1) = decl2;
403 decl1 = decl2;
404
405 decl2 = build_decl (FIELD_DECL, get_identifier ("upper"),
406 long_type);
407 DECL_INITIAL (decl2) = NULL_TREE;
408 TREE_CHAIN (decl1) = decl2;
409 TREE_CHAIN (decl2) = NULL_TREE;
410
411 result = build_chill_struct_type (listbase);
412 pushdecl (forcharrange = build_decl (TYPE_DECL,
413 get_identifier ("__tmp_IO_charrange"),
414 result));
415 DECL_SOURCE_LINE (forcharrange) = 0;
416 satisfy_decl (forcharrange, 0);
417
418 /* type for integer range */
419 decl1 = build_tree_list (NULL_TREE,
420 build_decl (FIELD_DECL,
421 get_identifier ("_slong"),
422 long_type));
423 listbase = decl1;
424
425 decl2 = build_tree_list (NULL_TREE,
426 build_decl (FIELD_DECL,
427 get_identifier ("_ulong"),
428 ulong_type));
429 TREE_CHAIN (decl1) = decl2;
430 TREE_CHAIN (decl2) = NULL_TREE;
431
432 decl1 = grok_chill_variantdefs (NULL_TREE, listbase, NULL_TREE);
433 TREE_CHAIN (decl1) = NULL_TREE;
434 result = build_chill_struct_type (decl1);
435 pushdecl (intunion = build_decl (TYPE_DECL,
436 get_identifier ("__tmp_IO_long"),
437 result));
438 DECL_SOURCE_LINE (intunion) = 0;
439 satisfy_decl (intunion, 0);
440
441 decl1 = build_decl (FIELD_DECL,
442 get_identifier ("ptr"),
443 ptr_type_node);
444 listbase = decl1;
445
446 decl2 = build_decl (FIELD_DECL,
447 get_identifier ("lower"),
448 TREE_TYPE (intunion));
449 TREE_CHAIN (decl1) = decl2;
450 decl1 = decl2;
451
452 decl2 = build_decl (FIELD_DECL,
453 get_identifier ("upper"),
454 TREE_TYPE (intunion));
455 TREE_CHAIN (decl1) = decl2;
456 TREE_CHAIN (decl2) = NULL_TREE;
457
458 result = build_chill_struct_type (listbase);
459 pushdecl (forintrange = build_decl (TYPE_DECL,
460 get_identifier ("__tmp_IO_intrange"),
461 result));
462 DECL_SOURCE_LINE (forintrange) = 0;
463 satisfy_decl (forintrange, 0);
464
465 /* build structure for bool range */
466 decl1 = build_decl (FIELD_DECL,
467 get_identifier ("ptr"),
468 ptr_type_node);
469 DECL_INITIAL (decl1) = NULL_TREE;
470 listbase = decl1;
471
472 decl2 = build_decl (FIELD_DECL,
473 get_identifier ("lower"),
474 ulong_type);
475 DECL_INITIAL (decl2) = NULL_TREE;
476 TREE_CHAIN (decl1) = decl2;
477 decl1 = decl2;
478
479 decl2 = build_decl (FIELD_DECL,
480 get_identifier ("upper"),
481 ulong_type);
482 DECL_INITIAL (decl2) = NULL_TREE;
483 TREE_CHAIN (decl1) = decl2;
484 TREE_CHAIN (decl2) = NULL_TREE;
485
486 result = build_chill_struct_type (listbase);
487 pushdecl (forboolrange = build_decl (TYPE_DECL,
488 get_identifier ("__tmp_RIO_boolrange"),
489 result));
490 DECL_SOURCE_LINE (forboolrange) = 0;
491 satisfy_decl (forboolrange, 0);
492
493 /* build type for reading a set */
494 decl1 = build_decl (FIELD_DECL, get_identifier ("ptr"),
495 ptr_type_node);
496 DECL_INITIAL (decl1) = NULL_TREE;
497 listbase = decl1;
498
499 decl2 = build_decl (FIELD_DECL, get_identifier ("length"),
500 long_type);
501 DECL_INITIAL (decl2) = NULL_TREE;
502 TREE_CHAIN (decl1) = decl2;
503 decl1 = decl2;
504
505 decl2 = build_decl (FIELD_DECL, get_identifier ("name_table"),
506 build_pointer_type (TREE_TYPE (enum_table_type)));
507 DECL_INITIAL (decl2) = NULL_TREE;
508 TREE_CHAIN (decl1) = decl2;
509 TREE_CHAIN (decl2) = NULL_TREE;
510
511 result = build_chill_struct_type (listbase);
512 pushdecl (forset_R = build_decl (TYPE_DECL,
513 get_identifier ("__tmp_RIO_set"),
514 result));
515 DECL_SOURCE_LINE (forset_R) = 0;
516 satisfy_decl (forset_R, 0);
517
518 /* build type for setrange */
519 decl1 = build_decl (FIELD_DECL, get_identifier ("ptr"),
520 ptr_type_node);
521 DECL_INITIAL (decl1) = NULL_TREE;
522 listbase = decl1;
523
524 decl2 = build_decl (FIELD_DECL, get_identifier ("length"),
525 long_type);
526 DECL_INITIAL (decl2) = NULL_TREE;
527 TREE_CHAIN (decl1) = decl2;
528 decl1 = decl2;
529
530 decl2 = build_decl (FIELD_DECL, get_identifier ("name_table"),
531 build_pointer_type (TREE_TYPE (enum_table_type)));
532 DECL_INITIAL (decl2) = NULL_TREE;
533 TREE_CHAIN (decl1) = decl2;
534 decl1 = decl2;
535
536 decl2 = build_decl (FIELD_DECL, get_identifier ("lower"),
537 long_type);
538 DECL_INITIAL (decl2) = NULL_TREE;
539 TREE_CHAIN (decl1) = decl2;
540 decl1 = decl2;
541
542 decl2 = build_decl (FIELD_DECL, get_identifier ("upper"),
543 long_type);
544 DECL_INITIAL (decl2) = NULL_TREE;
545 TREE_CHAIN (decl1) = decl2;
546 TREE_CHAIN (decl2) = NULL_TREE;
547
548 result = build_chill_struct_type (listbase);
549 pushdecl (forsetrange = build_decl (TYPE_DECL,
550 get_identifier ("__tmp_RIO_setrange"),
551 result));
552 DECL_SOURCE_LINE (forsetrange) = 0;
553 satisfy_decl (forsetrange, 0);
554
555 /* build structure for character string */
556 decl1 = build_decl (FIELD_DECL,
557 get_identifier ("string"),
558 build_pointer_type (char_type_node));
559 DECL_INITIAL (decl1) = NULL_TREE;
560 listbase = decl1;
561
562 decl2 = build_decl (FIELD_DECL,
563 get_identifier ("string_length"),
564 ulong_type);
565 DECL_INITIAL (decl2) = NULL_TREE;
566 TREE_CHAIN (decl1) = decl2;
567 decl1 = decl2;
568 TREE_CHAIN (decl2) = NULL_TREE;
569
570 result = build_chill_struct_type (listbase);
571 pushdecl (forcharstring = build_decl (TYPE_DECL,
572 get_identifier ("__tmp_IO_forcharstring"), result));
573 DECL_SOURCE_LINE (forcharstring) = 0;
574 satisfy_decl (forcharstring, 0);
575
576 /* build the union */
577 decl1 = build_tree_list (NULL_TREE,
578 build_decl (FIELD_DECL,
579 get_identifier ("__valbyte"),
580 signed_char_type_node));
581 listbase = decl1;
582
583 decl2 = build_tree_list (NULL_TREE,
584 build_decl (FIELD_DECL,
585 get_identifier ("__valubyte"),
586 unsigned_char_type_node));
587 TREE_CHAIN (decl1) = decl2;
588 decl1 = decl2;
589
590 decl2 = build_tree_list (NULL_TREE,
591 build_decl (FIELD_DECL,
592 get_identifier ("__valint"),
593 chill_integer_type_node));
594 TREE_CHAIN (decl1) = decl2;
595 decl1 = decl2;
596
597 decl2 = build_tree_list (NULL_TREE,
598 build_decl (FIELD_DECL,
599 get_identifier ("__valuint"),
600 chill_unsigned_type_node));
601 TREE_CHAIN (decl1) = decl2;
602 decl1 = decl2;
603
604 decl2 = build_tree_list (NULL_TREE,
605 build_decl (FIELD_DECL,
606 get_identifier ("__vallong"),
607 long_type));
608 TREE_CHAIN (decl1) = decl2;
609 decl1 = decl2;
610
611 decl2 = build_tree_list (NULL_TREE,
612 build_decl (FIELD_DECL,
613 get_identifier ("__valulong"),
614 ulong_type));
615 TREE_CHAIN (decl1) = decl2;
616 decl1 = decl2;
617
618 decl2 = build_tree_list (NULL_TREE,
619 build_decl (FIELD_DECL,
620 get_identifier ("__locint"),
621 ptr_type_node));
622 TREE_CHAIN (decl1) = decl2;
623 decl1 = decl2;
624
625 decl2 = build_tree_list (NULL_TREE,
626 build_decl (FIELD_DECL,
627 get_identifier ("__locintrange"),
628 TREE_TYPE (forintrange)));
629 TREE_CHAIN (decl1) = decl2;
630 decl1 = decl2;
631
632 decl2 = build_tree_list (NULL_TREE,
633 build_decl (FIELD_DECL,
634 get_identifier ("__valbool"),
635 boolean_type_node));
636 TREE_CHAIN (decl1) = decl2;
637 decl1 = decl2;
638
639 decl2 = build_tree_list (NULL_TREE,
640 build_decl (FIELD_DECL,
641 get_identifier ("__locbool"),
642 build_pointer_type (boolean_type_node)));
643 TREE_CHAIN (decl1) = decl2;
644 decl1 = decl2;
645
646 decl2 = build_tree_list (NULL_TREE,
647 build_decl (FIELD_DECL,
648 get_identifier ("__locboolrange"),
649 TREE_TYPE (forboolrange)));
650 TREE_CHAIN (decl1) = decl2;
651 decl1 = decl2;
652
653 decl2 = build_tree_list (NULL_TREE,
654 build_decl (FIELD_DECL,
655 get_identifier ("__valset"),
656 TREE_TYPE (forset_W)));
657 TREE_CHAIN (decl1) = decl2;
658 decl1 = decl2;
659
660 decl2 = build_tree_list (NULL_TREE,
661 build_decl (FIELD_DECL,
662 get_identifier ("__locset"),
663 TREE_TYPE (forset_R)));
664 TREE_CHAIN (decl1) = decl2;
665 decl1 = decl2;
666
667 decl2 = build_tree_list (NULL_TREE,
668 build_decl (FIELD_DECL,
669 get_identifier ("__locsetrange"),
670 TREE_TYPE (forsetrange)));
671 TREE_CHAIN (decl1) = decl2;
672 decl1 = decl2;
673
674 decl2 = build_tree_list (NULL_TREE,
675 build_decl (FIELD_DECL,
676 get_identifier ("__valchar"),
677 char_type_node));
678 TREE_CHAIN (decl1) = decl2;
679 decl1 = decl2;
680
681 decl2 = build_tree_list (NULL_TREE,
682 build_decl (FIELD_DECL,
683 get_identifier ("__locchar"),
684 build_pointer_type (char_type_node)));
685 TREE_CHAIN (decl1) = decl2;
686 decl1 = decl2;
687
688 decl2 = build_tree_list (NULL_TREE,
689 build_decl (FIELD_DECL,
690 get_identifier ("__loccharrange"),
691 TREE_TYPE (forcharrange)));
692 TREE_CHAIN (decl1) = decl2;
693 decl1 = decl2;
694
695 decl2 = build_tree_list (NULL_TREE,
696 build_decl (FIELD_DECL,
697 get_identifier ("__loccharstring"),
698 TREE_TYPE (forcharstring)));
699 TREE_CHAIN (decl1) = decl2;
700 decl1 = decl2;
701
702 decl2 = build_tree_list (NULL_TREE,
703 build_decl (FIELD_DECL,
704 get_identifier ("__valreal"),
705 float_type_node));
706 TREE_CHAIN (decl1) = decl2;
707 decl1 = decl2;
708
709 decl2 = build_tree_list (NULL_TREE,
710 build_decl (FIELD_DECL,
711 get_identifier ("__locreal"),
712 build_pointer_type (float_type_node)));
713 TREE_CHAIN (decl1) = decl2;
714 decl1 = decl2;
715
716 decl2 = build_tree_list (NULL_TREE,
717 build_decl (FIELD_DECL,
718 get_identifier ("__vallongreal"),
719 double_type_node));
720 TREE_CHAIN (decl1) = decl2;
721 decl1 = decl2;
722
723 decl2 = build_tree_list (NULL_TREE,
724 build_decl (FIELD_DECL,
725 get_identifier ("__loclongreal"),
726 build_pointer_type (double_type_node)));
727 TREE_CHAIN (decl1) = decl2;
728 decl1 = decl2;
729
730 #if 0
731 decl2 = build_tree_list (NULL_TREE,
732 build_decl (FIELD_DECL,
733 get_identifier ("__forpointer"),
734 ptr_type_node));
735 TREE_CHAIN (decl1) = decl2;
736 decl1 = decl2;
737 #endif
738
739 TREE_CHAIN (decl2) = NULL_TREE;
740
741 decl1 = grok_chill_variantdefs (NULL_TREE, listbase, NULL_TREE);
742 TREE_CHAIN (decl1) = NULL_TREE;
743 result = build_chill_struct_type (decl1);
744 pushdecl (union_type = build_decl (TYPE_DECL,
745 get_identifier ("__tmp_WIO_union"),
746 result));
747 DECL_SOURCE_LINE (union_type) = 0;
748 satisfy_decl (union_type, 0);
749
750 /* now build the final structure */
751 decl1 = build_decl (FIELD_DECL, get_identifier ("__t"),
752 TREE_TYPE (union_type));
753 DECL_INITIAL (decl1) = NULL_TREE;
754 listbase = decl1;
755
756 decl2 = build_decl (FIELD_DECL, get_identifier ("__descr"),
757 long_type);
758
759 TREE_CHAIN (decl1) = decl2;
760 TREE_CHAIN (decl2) = NULL_TREE;
761
762 result = build_chill_struct_type (listbase);
763 pushdecl (chill_io_list_type = build_decl (TYPE_DECL,
764 get_identifier ("__tmp_IO_list"),
765 result));
766 DECL_SOURCE_LINE (chill_io_list_type) = 0;
767 satisfy_decl (chill_io_list_type, 0);
768 }
769 \f
770 /* build the ASSOCIATION, ACCESS and TEXT mode types */
771 static void
772 build_io_types ()
773 {
774 tree listbase, decl1, decl2, result, association;
775 tree acc, txt, tloc;
776 tree enum1, tmp;
777
778 /* the association mode */
779 listbase = build_decl (FIELD_DECL,
780 get_identifier ("flags"),
781 long_unsigned_type_node);
782 DECL_INITIAL (listbase) = NULL_TREE;
783 decl1 = listbase;
784
785 decl2 = build_decl (FIELD_DECL,
786 get_identifier ("pathname"),
787 ptr_type_node);
788 DECL_INITIAL (decl2) = NULL_TREE;
789 TREE_CHAIN (decl1) = decl2;
790 decl1 = decl2;
791
792 decl2 = build_decl (FIELD_DECL,
793 get_identifier ("access"),
794 ptr_type_node);
795 DECL_INITIAL (decl2) = NULL_TREE;
796 TREE_CHAIN (decl1) = decl2;
797 decl1 = decl2;
798
799 decl2 = build_decl (FIELD_DECL,
800 get_identifier ("handle"),
801 integer_type_node);
802 DECL_INITIAL (decl2) = NULL_TREE;
803 TREE_CHAIN (decl1) = decl2;
804 decl1 = decl2;
805
806 decl2 = build_decl (FIELD_DECL,
807 get_identifier ("bufptr"),
808 ptr_type_node);
809 DECL_INITIAL (decl2) = NULL_TREE;
810 TREE_CHAIN (decl1) = decl2;
811 decl1 = decl2;
812
813 decl2 = build_decl (FIELD_DECL,
814 get_identifier ("syserrno"),
815 long_integer_type_node);
816 DECL_INITIAL (decl2) = NULL_TREE;
817 TREE_CHAIN (decl1) = decl2;
818 decl1 = decl2;
819
820 decl2 = build_decl (FIELD_DECL,
821 get_identifier ("usage"),
822 char_type_node);
823 DECL_INITIAL (decl2) = NULL_TREE;
824 TREE_CHAIN (decl1) = decl2;
825 decl1 = decl2;
826
827 decl2 = build_decl (FIELD_DECL,
828 get_identifier ("ctl_pre"),
829 char_type_node);
830 DECL_INITIAL (decl2) = NULL_TREE;
831 TREE_CHAIN (decl1) = decl2;
832 decl1 = decl2;
833
834 decl2 = build_decl (FIELD_DECL,
835 get_identifier ("ctl_post"),
836 char_type_node);
837 DECL_INITIAL (decl2) = NULL_TREE;
838 TREE_CHAIN (decl1) = decl2;
839 TREE_CHAIN (decl2) = NULL_TREE;
840
841 result = build_chill_struct_type (listbase);
842 pushdecl (association = build_decl (TYPE_DECL,
843 ridpointers[(int)RID_ASSOCIATION],
844 result));
845 DECL_SOURCE_LINE (association) = 0;
846 satisfy_decl (association, 0);
847 association_type_node = TREE_TYPE (association);
848 TYPE_NAME (association_type_node) = association;
849 CH_NOVELTY (association_type_node) = association;
850 CH_TYPE_NONVALUE_P(association_type_node) = 1;
851 CH_TYPE_NONVALUE_P(association) = 1;
852
853 /* initialiser for association type */
854 tmp = convert (char_type_node, integer_zero_node);
855 association_init_value =
856 build_nt (CONSTRUCTOR, NULL_TREE,
857 tree_cons (NULL_TREE, integer_zero_node, /* flags */
858 tree_cons (NULL_TREE, null_pointer_node, /* pathname */
859 tree_cons (NULL_TREE, null_pointer_node, /* access */
860 tree_cons (NULL_TREE, integer_minus_one_node, /* handle */
861 tree_cons (NULL_TREE, null_pointer_node, /* bufptr */
862 tree_cons (NULL_TREE, integer_zero_node, /* syserrno */
863 tree_cons (NULL_TREE, tmp, /* usage */
864 tree_cons (NULL_TREE, tmp, /* ctl_pre */
865 tree_cons (NULL_TREE, tmp, /* ctl_post */
866 NULL_TREE))))))))));
867
868 /* the type for stdin, stdout, stderr */
869 /* text part */
870 decl1 = build_decl (FIELD_DECL,
871 get_identifier ("flags"),
872 long_unsigned_type_node);
873 DECL_INITIAL (decl1) = NULL_TREE;
874 listbase = decl1;
875
876 decl2 = build_decl (FIELD_DECL,
877 get_identifier ("text_record"),
878 ptr_type_node);
879 DECL_INITIAL (decl2) = NULL_TREE;
880 TREE_CHAIN (decl1) = decl2;
881 decl1 = decl2;
882
883 decl2 = build_decl (FIELD_DECL,
884 get_identifier ("access_sub"),
885 ptr_type_node);
886 DECL_INITIAL (decl2) = NULL_TREE;
887 TREE_CHAIN (decl1) = decl2;
888 decl1 = decl2;
889
890 decl2 = build_decl (FIELD_DECL,
891 get_identifier ("actual_index"),
892 long_unsigned_type_node);
893 DECL_INITIAL (decl2) = NULL_TREE;
894 TREE_CHAIN (decl1) = decl2;
895 TREE_CHAIN (decl2) = NULL_TREE;
896 txt = build_chill_struct_type (listbase);
897
898 /* access part */
899 decl1 = build_decl (FIELD_DECL,
900 get_identifier ("flags"),
901 long_unsigned_type_node);
902 DECL_INITIAL (decl1) = NULL_TREE;
903 listbase = decl1;
904
905 decl2 = build_decl (FIELD_DECL,
906 get_identifier ("reclength"),
907 long_unsigned_type_node);
908 DECL_INITIAL (decl2) = NULL_TREE;
909 TREE_CHAIN (decl1) = decl2;
910 decl1 = decl2;
911
912 decl2 = build_decl (FIELD_DECL,
913 get_identifier ("lowindex"),
914 long_integer_type_node);
915 DECL_INITIAL (decl2) = NULL_TREE;
916 TREE_CHAIN (decl1) = decl2;
917 decl1 = decl2;
918
919 decl2 = build_decl (FIELD_DECL,
920 get_identifier ("highindex"),
921 long_integer_type_node);
922 DECL_INITIAL (decl2) = NULL_TREE;
923 TREE_CHAIN (decl1) = decl2;
924 decl2 = decl1;
925
926 decl2 = build_decl (FIELD_DECL,
927 get_identifier ("association"),
928 ptr_type_node);
929 DECL_INITIAL (decl2) = NULL_TREE;
930 TREE_CHAIN (decl1) = decl2;
931 decl1 = decl2;
932
933 decl2 = build_decl (FIELD_DECL,
934 get_identifier ("base"),
935 long_unsigned_type_node);
936 DECL_INITIAL (decl2) = NULL_TREE;
937 TREE_CHAIN (decl1) = decl2;
938 decl1 = decl2;
939
940 decl2 = build_decl (FIELD_DECL,
941 get_identifier ("storelocptr"),
942 ptr_type_node);
943 DECL_INITIAL (decl2) = NULL_TREE;
944 TREE_CHAIN (decl1) = decl2;
945 decl1 = decl2;
946
947 decl2 = build_decl (FIELD_DECL,
948 get_identifier ("rectype"),
949 long_integer_type_node);
950 DECL_INITIAL (decl2) = NULL_TREE;
951 TREE_CHAIN (decl1) = decl2;
952 TREE_CHAIN (decl2) = NULL_TREE;
953 acc = build_chill_struct_type (listbase);
954
955 /* the location */
956 tmp = build_string_type (char_type_node, build_int_2 (STDIO_TEXT_LENGTH, 0));
957 tloc = build_varying_struct (tmp);
958
959 /* now the final mode */
960 decl1 = build_decl (FIELD_DECL, get_identifier ("txt"), txt);
961 listbase = decl1;
962
963 decl2 = build_decl (FIELD_DECL, get_identifier ("acc"), acc);
964 TREE_CHAIN (decl1) = decl2;
965 decl1 = decl2;
966
967 decl2 = build_decl (FIELD_DECL, get_identifier ("tloc"), tloc);
968 TREE_CHAIN (decl1) = decl2;
969 decl1 = decl2;
970
971 decl2 = build_lang_decl (TYPE_DECL, get_identifier ("__indexmode"),
972 void_type_node);
973 TREE_CHAIN (decl1) = decl2;
974 decl1 = decl2;
975
976 decl2 = build_decl (CONST_DECL, get_identifier ("__textlength"),
977 integer_type_node);
978 DECL_INITIAL (decl2) = build_int_2 (STDIO_TEXT_LENGTH, 0);
979 TREE_CHAIN (decl1) = decl2;
980 decl1 = decl2;
981
982 decl2 = build_decl (CONST_DECL, get_identifier ("__dynamic"),
983 integer_type_node);
984 DECL_INITIAL (decl2) = integer_zero_node;
985 TREE_CHAIN (decl1) = decl2;
986 TREE_CHAIN (decl2) = NULL_TREE;
987
988 result = build_chill_struct_type (listbase);
989 pushdecl (tmp = build_decl (TYPE_DECL,
990 get_identifier ("__stdio_text"),
991 result));
992 DECL_SOURCE_LINE (tmp) = 0;
993 satisfy_decl (tmp, 0);
994 stdio_type_node = TREE_TYPE (tmp);
995 CH_IS_TEXT_MODE (stdio_type_node) = 1;
996
997 /* predefined usage mode */
998 enum1 = start_enum (NULL_TREE);
999 listbase = NULL_TREE;
1000 result = build_enumerator (
1001 get_identifier ((ignore_case || ! special_UC) ? "readonly" : "READONLY"),
1002 NULL_TREE);
1003 listbase = chainon (result, listbase);
1004 result = build_enumerator (
1005 get_identifier ((ignore_case || ! special_UC) ? "writeonly" : "WRITEONLY"),
1006 NULL_TREE);
1007 listbase = chainon (result, listbase);
1008 result = build_enumerator (
1009 get_identifier ((ignore_case || ! special_UC) ? "readwrite" : "READWRITE"),
1010 NULL_TREE);
1011 listbase = chainon (result, listbase);
1012 result = finish_enum (enum1, listbase);
1013 pushdecl (tmp = build_decl (TYPE_DECL,
1014 get_identifier ((ignore_case || ! special_UC) ? "usage" : "USAGE"),
1015 result));
1016 DECL_SOURCE_LINE (tmp) = 0;
1017 satisfy_decl (tmp, 0);
1018 usage_type_node = TREE_TYPE (tmp);
1019 TYPE_NAME (usage_type_node) = tmp;
1020 CH_NOVELTY (usage_type_node) = tmp;
1021
1022 /* predefined where mode */
1023 enum1 = start_enum (NULL_TREE);
1024 listbase = NULL_TREE;
1025 result = build_enumerator (
1026 get_identifier ((ignore_case || ! special_UC) ? "first" : "FIRST"),
1027 NULL_TREE);
1028 listbase = chainon (result, listbase);
1029 result = build_enumerator (
1030 get_identifier ((ignore_case || ! special_UC) ? "same" : "SAME"),
1031 NULL_TREE);
1032 listbase = chainon (result, listbase);
1033 result = build_enumerator (
1034 get_identifier ((ignore_case || ! special_UC) ? "last" : "LAST"),
1035 NULL_TREE);
1036 listbase = chainon (result, listbase);
1037 result = finish_enum (enum1, listbase);
1038 pushdecl (tmp = build_decl (TYPE_DECL,
1039 get_identifier ((ignore_case || ! special_UC) ? "where" : "WHERE"),
1040 result));
1041 DECL_SOURCE_LINE (tmp) = 0;
1042 satisfy_decl (tmp, 0);
1043 where_type_node = TREE_TYPE (tmp);
1044 TYPE_NAME (where_type_node) = tmp;
1045 CH_NOVELTY (where_type_node) = tmp;
1046 }
1047 \f
1048 static void
1049 declare_predefined_file (name, assembler_name)
1050 char *name;
1051 char* assembler_name;
1052 {
1053 tree decl = build_lang_decl (VAR_DECL, get_identifier (name),
1054 stdio_type_node);
1055 DECL_ASSEMBLER_NAME (decl) = get_identifier(assembler_name);
1056 TREE_STATIC (decl) = 1;
1057 TREE_PUBLIC (decl) = 1;
1058 DECL_EXTERNAL (decl) = 1;
1059 DECL_IN_SYSTEM_HEADER (decl) = 1;
1060 make_decl_rtl (decl, 0, 1);
1061 pushdecl (decl);
1062 }
1063 \f
1064
1065 /* initialisation of all IO/related functions, types, etc. */
1066 void
1067 inout_init ()
1068 {
1069 /* We temporarily reset the maximum_field_alignment to zero so the
1070 compiler's init data structures can be compatible with the
1071 run-time system, even when we're compiling with -fpack. */
1072 extern int maximum_field_alignment;
1073 int save_maximum_field_alignment = maximum_field_alignment;
1074
1075 extern tree chill_predefined_function_type;
1076 tree endlink = void_list_node;
1077 tree bool_ftype_ptr_ptr_int;
1078 tree ptr_ftype_ptr_ptr_int;
1079 tree luns_ftype_ptr_ptr_int;
1080 tree int_ftype_ptr_ptr_int;
1081 tree ptr_ftype_ptr_ptr_int_ptr_int_ptr_int;
1082 tree void_ftype_ptr_ptr_int_ptr_int_ptr_int;
1083 tree void_ftype_ptr_ptr_int;
1084 tree void_ftype_ptr_ptr_int_int_int_long_ptr_int;
1085 tree ptr_ftype_ptr_int_ptr_ptr_int;
1086 tree void_ftype_ptr_int_ptr_luns_ptr_int;
1087 tree void_ftype_ptr_ptr_ptr_int;
1088 tree void_ftype_ptr_int_ptr_int;
1089 tree void_ftype_ptr_int_ptr_int_ptr_int_ptr_int;
1090
1091 maximum_field_alignment = 0;
1092
1093 builtin_function ((ignore_case || ! special_UC) ? "associate" : "ASSOCIATE",
1094 chill_predefined_function_type,
1095 BUILT_IN_ASSOCIATE, NULL_PTR);
1096 builtin_function ((ignore_case || ! special_UC) ? "connect" : "CONNECT",
1097 chill_predefined_function_type,
1098 BUILT_IN_CONNECT, NULL_PTR);
1099 builtin_function ((ignore_case || ! special_UC) ? "create" : "CREATE",
1100 chill_predefined_function_type,
1101 BUILT_IN_CREATE, NULL_PTR);
1102 builtin_function ((ignore_case || ! special_UC) ? "delete" : "DELETE",
1103 chill_predefined_function_type,
1104 BUILT_IN_CH_DELETE, NULL_PTR);
1105 builtin_function ((ignore_case || ! special_UC) ? "disconnect" : "DISCONNECT",
1106 chill_predefined_function_type,
1107 BUILT_IN_DISCONNECT, NULL_PTR);
1108 builtin_function ((ignore_case || ! special_UC) ? "dissociate" : "DISSOCIATE",
1109 chill_predefined_function_type,
1110 BUILT_IN_DISSOCIATE, NULL_PTR);
1111 builtin_function ((ignore_case || ! special_UC) ? "eoln" : "EOLN",
1112 chill_predefined_function_type,
1113 BUILT_IN_EOLN, NULL_PTR);
1114 builtin_function ((ignore_case || ! special_UC) ? "existing" : "EXISTING",
1115 chill_predefined_function_type,
1116 BUILT_IN_EXISTING, NULL_PTR);
1117 builtin_function ((ignore_case || ! special_UC) ? "getassociation" : "GETASSOCIATION",
1118 chill_predefined_function_type,
1119 BUILT_IN_GETASSOCIATION, NULL_PTR);
1120 builtin_function ((ignore_case || ! special_UC) ? "gettextaccess" : "GETTEXTASSCESS",
1121 chill_predefined_function_type,
1122 BUILT_IN_GETTEXTACCESS, NULL_PTR);
1123 builtin_function ((ignore_case || ! special_UC) ? "gettextindex" : "GETTEXTINDEX",
1124 chill_predefined_function_type,
1125 BUILT_IN_GETTEXTINDEX, NULL_PTR);
1126 builtin_function ((ignore_case || ! special_UC) ? "gettextrecord" : "GETTEXTRECORD",
1127 chill_predefined_function_type,
1128 BUILT_IN_GETTEXTRECORD, NULL_PTR);
1129 builtin_function ((ignore_case || ! special_UC) ? "getusage" : "GETUSAGE",
1130 chill_predefined_function_type,
1131 BUILT_IN_GETUSAGE, NULL_PTR);
1132 builtin_function ((ignore_case || ! special_UC) ? "indexable" : "INDEXABLE",
1133 chill_predefined_function_type,
1134 BUILT_IN_INDEXABLE, NULL_PTR);
1135 builtin_function ((ignore_case || ! special_UC) ? "isassociated" : "ISASSOCIATED",
1136 chill_predefined_function_type,
1137 BUILT_IN_ISASSOCIATED, NULL_PTR);
1138 builtin_function ((ignore_case || ! special_UC) ? "modify" : "MODIFY",
1139 chill_predefined_function_type,
1140 BUILT_IN_MODIFY, NULL_PTR);
1141 builtin_function ((ignore_case || ! special_UC) ? "outoffile" : "OUTOFFILE",
1142 chill_predefined_function_type,
1143 BUILT_IN_OUTOFFILE, NULL_PTR);
1144 builtin_function ((ignore_case || ! special_UC) ? "readable" : "READABLE",
1145 chill_predefined_function_type,
1146 BUILT_IN_READABLE, NULL_PTR);
1147 builtin_function ((ignore_case || ! special_UC) ? "readrecord" : "READRECORD",
1148 chill_predefined_function_type,
1149 BUILT_IN_READRECORD, NULL_PTR);
1150 builtin_function ((ignore_case || ! special_UC) ? "readtext" : "READTEXT",
1151 chill_predefined_function_type,
1152 BUILT_IN_READTEXT, NULL_PTR);
1153 builtin_function ((ignore_case || ! special_UC) ? "sequencible" : "SEQUENCIBLE",
1154 chill_predefined_function_type,
1155 BUILT_IN_SEQUENCIBLE, NULL_PTR);
1156 builtin_function ((ignore_case || ! special_UC) ? "settextaccess" : "SETTEXTACCESS",
1157 chill_predefined_function_type,
1158 BUILT_IN_SETTEXTACCESS, NULL_PTR);
1159 builtin_function ((ignore_case || ! special_UC) ? "settextindex" : "SETTEXTINDEX",
1160 chill_predefined_function_type,
1161 BUILT_IN_SETTEXTINDEX, NULL_PTR);
1162 builtin_function ((ignore_case || ! special_UC) ? "settextrecord" : "SETTEXTRECORD",
1163 chill_predefined_function_type,
1164 BUILT_IN_SETTEXTRECORD, NULL_PTR);
1165 builtin_function ((ignore_case || ! special_UC) ? "variable" : "VARIABLE",
1166 chill_predefined_function_type,
1167 BUILT_IN_VARIABLE, NULL_PTR);
1168 builtin_function ((ignore_case || ! special_UC) ? "writeable" : "WRITEABLE",
1169 chill_predefined_function_type,
1170 BUILT_IN_WRITEABLE, NULL_PTR);
1171 builtin_function ((ignore_case || ! special_UC) ? "writerecord" : "WRITERECORD",
1172 chill_predefined_function_type,
1173 BUILT_IN_WRITERECORD, NULL_PTR);
1174 builtin_function ((ignore_case || ! special_UC) ? "writetext" : "WRITETEXT",
1175 chill_predefined_function_type,
1176 BUILT_IN_WRITETEXT, NULL_PTR);
1177
1178 /* build function prototypes */
1179 bool_ftype_ptr_ptr_int =
1180 build_function_type (boolean_type_node,
1181 tree_cons (NULL_TREE, ptr_type_node,
1182 tree_cons (NULL_TREE, ptr_type_node,
1183 tree_cons (NULL_TREE, integer_type_node,
1184 endlink))));
1185 ptr_ftype_ptr_ptr_int_ptr_int_ptr_int =
1186 build_function_type (ptr_type_node,
1187 tree_cons (NULL_TREE, ptr_type_node,
1188 tree_cons (NULL_TREE, ptr_type_node,
1189 tree_cons (NULL_TREE, integer_type_node,
1190 tree_cons (NULL_TREE, ptr_type_node,
1191 tree_cons (NULL_TREE, integer_type_node,
1192 tree_cons (NULL_TREE, ptr_type_node,
1193 tree_cons (NULL_TREE, integer_type_node,
1194 endlink))))))));
1195 void_ftype_ptr_ptr_int =
1196 build_function_type (void_type_node,
1197 tree_cons (NULL_TREE, ptr_type_node,
1198 tree_cons (NULL_TREE, ptr_type_node,
1199 tree_cons (NULL_TREE, integer_type_node,
1200 endlink))));
1201 void_ftype_ptr_ptr_int_ptr_int_ptr_int =
1202 build_function_type (void_type_node,
1203 tree_cons (NULL_TREE, ptr_type_node,
1204 tree_cons (NULL_TREE, ptr_type_node,
1205 tree_cons (NULL_TREE, integer_type_node,
1206 tree_cons (NULL_TREE, ptr_type_node,
1207 tree_cons (NULL_TREE, integer_type_node,
1208 tree_cons (NULL_TREE, ptr_type_node,
1209 tree_cons (NULL_TREE, integer_type_node,
1210 endlink))))))));
1211 void_ftype_ptr_ptr_int_int_int_long_ptr_int =
1212 build_function_type (void_type_node,
1213 tree_cons (NULL_TREE, ptr_type_node,
1214 tree_cons (NULL_TREE, ptr_type_node,
1215 tree_cons (NULL_TREE, integer_type_node,
1216 tree_cons (NULL_TREE, integer_type_node,
1217 tree_cons (NULL_TREE, integer_type_node,
1218 tree_cons (NULL_TREE, long_integer_type_node,
1219 tree_cons (NULL_TREE, ptr_type_node,
1220 tree_cons (NULL_TREE, integer_type_node,
1221 endlink)))))))));
1222 ptr_ftype_ptr_ptr_int =
1223 build_function_type (ptr_type_node,
1224 tree_cons (NULL_TREE, ptr_type_node,
1225 tree_cons (NULL_TREE, ptr_type_node,
1226 tree_cons (NULL_TREE, integer_type_node,
1227 endlink))));
1228 int_ftype_ptr_ptr_int =
1229 build_function_type (integer_type_node,
1230 tree_cons (NULL_TREE, ptr_type_node,
1231 tree_cons (NULL_TREE, ptr_type_node,
1232 tree_cons (NULL_TREE, integer_type_node,
1233 endlink))));
1234 ptr_ftype_ptr_int_ptr_ptr_int =
1235 build_function_type (ptr_type_node,
1236 tree_cons (NULL_TREE, ptr_type_node,
1237 tree_cons (NULL_TREE, integer_type_node,
1238 tree_cons (NULL_TREE, ptr_type_node,
1239 tree_cons (NULL_TREE, ptr_type_node,
1240 tree_cons (NULL_TREE, integer_type_node,
1241 endlink))))));
1242 void_ftype_ptr_int_ptr_luns_ptr_int =
1243 build_function_type (void_type_node,
1244 tree_cons (NULL_TREE, ptr_type_node,
1245 tree_cons (NULL_TREE, integer_type_node,
1246 tree_cons (NULL_TREE, ptr_type_node,
1247 tree_cons (NULL_TREE, long_unsigned_type_node,
1248 tree_cons (NULL_TREE, ptr_type_node,
1249 tree_cons (NULL_TREE, integer_type_node,
1250 endlink)))))));
1251 luns_ftype_ptr_ptr_int =
1252 build_function_type (long_unsigned_type_node,
1253 tree_cons (NULL_TREE, ptr_type_node,
1254 tree_cons (NULL_TREE, ptr_type_node,
1255 tree_cons (NULL_TREE, integer_type_node,
1256 endlink))));
1257 void_ftype_ptr_ptr_ptr_int =
1258 build_function_type (void_type_node,
1259 tree_cons (NULL_TREE, ptr_type_node,
1260 tree_cons (NULL_TREE, ptr_type_node,
1261 tree_cons (NULL_TREE, ptr_type_node,
1262 tree_cons (NULL_TREE, integer_type_node,
1263 endlink)))));
1264 void_ftype_ptr_int_ptr_int =
1265 build_function_type (void_type_node,
1266 tree_cons (NULL_TREE, ptr_type_node,
1267 tree_cons (NULL_TREE, integer_type_node,
1268 tree_cons (NULL_TREE, ptr_type_node,
1269 tree_cons (NULL_TREE, integer_type_node,
1270 endlink)))));
1271 void_ftype_ptr_int_ptr_int_ptr_int_ptr_int =
1272 build_function_type (void_type_node,
1273 tree_cons (NULL_TREE, ptr_type_node,
1274 tree_cons (NULL_TREE, integer_type_node,
1275 tree_cons (NULL_TREE, ptr_type_node,
1276 tree_cons (NULL_TREE, integer_type_node,
1277 tree_cons (NULL_TREE, ptr_type_node,
1278 tree_cons (NULL_TREE, integer_type_node,
1279 tree_cons (NULL_TREE, ptr_type_node,
1280 tree_cons (NULL_TREE, integer_type_node,
1281 endlink)))))))));
1282
1283 builtin_function ("__associate", ptr_ftype_ptr_ptr_int_ptr_int_ptr_int,
1284 NOT_BUILT_IN, NULL_PTR);
1285 builtin_function ("__connect", void_ftype_ptr_ptr_int_int_int_long_ptr_int,
1286 NOT_BUILT_IN, NULL_PTR);
1287 builtin_function ("__create", void_ftype_ptr_ptr_int,
1288 NOT_BUILT_IN, NULL_PTR);
1289 builtin_function ("__delete", void_ftype_ptr_ptr_int,
1290 NOT_BUILT_IN, NULL_PTR);
1291 builtin_function ("__disconnect", void_ftype_ptr_ptr_int,
1292 NOT_BUILT_IN, NULL_PTR);
1293 builtin_function ("__dissociate", void_ftype_ptr_ptr_int,
1294 NOT_BUILT_IN, NULL_PTR);
1295 builtin_function ("__eoln", bool_ftype_ptr_ptr_int,
1296 NOT_BUILT_IN, NULL_PTR);
1297 builtin_function ("__existing", bool_ftype_ptr_ptr_int,
1298 NOT_BUILT_IN, NULL_PTR);
1299 builtin_function ("__getassociation", ptr_ftype_ptr_ptr_int,
1300 NOT_BUILT_IN, NULL_PTR);
1301 builtin_function ("__gettextaccess", ptr_ftype_ptr_ptr_int,
1302 NOT_BUILT_IN, NULL_PTR);
1303 builtin_function ("__gettextindex", luns_ftype_ptr_ptr_int,
1304 NOT_BUILT_IN, NULL_PTR);
1305 builtin_function ("__gettextrecord", ptr_ftype_ptr_ptr_int,
1306 NOT_BUILT_IN, NULL_PTR);
1307 builtin_function ("__getusage", int_ftype_ptr_ptr_int,
1308 NOT_BUILT_IN, NULL_PTR);
1309 builtin_function ("__indexable", bool_ftype_ptr_ptr_int,
1310 NOT_BUILT_IN, NULL_PTR);
1311 builtin_function ("__isassociated", bool_ftype_ptr_ptr_int,
1312 NOT_BUILT_IN, NULL_PTR);
1313 builtin_function ("__modify", void_ftype_ptr_ptr_int_ptr_int_ptr_int,
1314 NOT_BUILT_IN, NULL_PTR);
1315 builtin_function ("__outoffile", bool_ftype_ptr_ptr_int,
1316 NOT_BUILT_IN, NULL_PTR);
1317 builtin_function ("__readable", bool_ftype_ptr_ptr_int,
1318 NOT_BUILT_IN, NULL_PTR);
1319 builtin_function ("__readrecord", ptr_ftype_ptr_int_ptr_ptr_int,
1320 NOT_BUILT_IN, NULL_PTR);
1321 builtin_function ("__readtext_f", void_ftype_ptr_int_ptr_int_ptr_int_ptr_int,
1322 NOT_BUILT_IN, NULL_PTR);
1323 builtin_function ("__readtext_s", void_ftype_ptr_int_ptr_int_ptr_int_ptr_int,
1324 NOT_BUILT_IN, NULL_PTR);
1325 builtin_function ("__sequencible", bool_ftype_ptr_ptr_int,
1326 NOT_BUILT_IN, NULL_PTR);
1327 builtin_function ("__settextaccess", void_ftype_ptr_ptr_ptr_int,
1328 NOT_BUILT_IN, NULL_PTR);
1329 builtin_function ("__settextindex", void_ftype_ptr_int_ptr_int,
1330 NOT_BUILT_IN, NULL_PTR);
1331 builtin_function ("__settextrecord", void_ftype_ptr_ptr_ptr_int,
1332 NOT_BUILT_IN, NULL_PTR);
1333 builtin_function ("__variable", bool_ftype_ptr_ptr_int,
1334 NOT_BUILT_IN, NULL_PTR);
1335 builtin_function ("__writeable", bool_ftype_ptr_ptr_int,
1336 NOT_BUILT_IN, NULL_PTR);
1337 builtin_function ("__writerecord", void_ftype_ptr_int_ptr_luns_ptr_int,
1338 NOT_BUILT_IN, NULL_PTR);
1339 builtin_function ("__writetext_f", void_ftype_ptr_int_ptr_int_ptr_int_ptr_int,
1340 NOT_BUILT_IN, NULL_PTR);
1341 builtin_function ("__writetext_s", void_ftype_ptr_int_ptr_int_ptr_int_ptr_int,
1342 NOT_BUILT_IN, NULL_PTR);
1343
1344 /* declare ASSOCIATION, ACCESS, and TEXT modes */
1345 build_io_types ();
1346
1347 /* declare the predefined text locations */
1348 declare_predefined_file ((ignore_case || ! special_UC) ? "stdin" : "STDIN",
1349 "chill_stdin");
1350 declare_predefined_file ((ignore_case || ! special_UC) ? "stdout" : "STDOUT",
1351 "chill_stdout");
1352 declare_predefined_file ((ignore_case || ! special_UC) ? "stderr" : "STDERR",
1353 "chill_stderr");
1354
1355 /* last, but not least, build the chill IO-list type */
1356 build_chill_io_list_type ();
1357
1358 maximum_field_alignment = save_maximum_field_alignment;
1359 }
1360 \f
1361 /* function returns the recordmode of an ACCESS */
1362 tree
1363 access_recordmode (access)
1364 tree access;
1365 {
1366 tree field;
1367
1368 if (access == NULL_TREE || TREE_CODE (access) == ERROR_MARK)
1369 return NULL_TREE;
1370 if (! CH_IS_ACCESS_MODE (access))
1371 return NULL_TREE;
1372
1373 field = TYPE_FIELDS (access);
1374 for ( ; field != NULL_TREE; field = TREE_CHAIN (field))
1375 {
1376 if (TREE_CODE (field) == TYPE_DECL &&
1377 DECL_NAME (field) == get_identifier ("__recordmode"))
1378 return TREE_TYPE (field);
1379 }
1380 return void_type_node;
1381 }
1382
1383 /* function invalidates the recordmode of an ACCESS */
1384 void
1385 invalidate_access_recordmode (access)
1386 tree access;
1387 {
1388 tree field;
1389
1390 if (access == NULL_TREE || TREE_CODE (access) == ERROR_MARK)
1391 return;
1392 if (! CH_IS_ACCESS_MODE (access))
1393 return;
1394
1395 field = TYPE_FIELDS (access);
1396 for ( ; field != NULL_TREE; field = TREE_CHAIN (field))
1397 {
1398 if (TREE_CODE (field) == TYPE_DECL &&
1399 DECL_NAME (field) == get_identifier ("__recordmode"))
1400 {
1401 TREE_TYPE (field) = error_mark_node;
1402 return;
1403 }
1404 }
1405 }
1406
1407 /* function returns the index mode of an ACCESS if there is one,
1408 otherwise NULL_TREE */
1409 tree
1410 access_indexmode (access)
1411 tree access;
1412 {
1413 tree field;
1414
1415 if (access == NULL_TREE || TREE_CODE (access) == ERROR_MARK)
1416 return NULL_TREE;
1417 if (! CH_IS_ACCESS_MODE (access))
1418 return NULL_TREE;
1419
1420 field = TYPE_FIELDS (access);
1421 for ( ; field != NULL_TREE; field = TREE_CHAIN (field))
1422 {
1423 if (TREE_CODE (field) == TYPE_DECL &&
1424 DECL_NAME (field) == get_identifier ("__indexmode"))
1425 return TREE_TYPE (field);
1426 }
1427 return void_type_node;
1428 }
1429
1430 /* function returns one if an ACCESS was specified DYNAMIC, otherwise zero */
1431 tree
1432 access_dynamic (access)
1433 tree access;
1434 {
1435 tree field;
1436
1437 if (access == NULL_TREE || TREE_CODE (access) == ERROR_MARK)
1438 return NULL_TREE;
1439 if (! CH_IS_ACCESS_MODE (access))
1440 return NULL_TREE;
1441
1442 field = TYPE_FIELDS (access);
1443 for ( ; field != NULL_TREE; field = TREE_CHAIN (field))
1444 {
1445 if (TREE_CODE (field) == CONST_DECL)
1446 return DECL_INITIAL (field);
1447 }
1448 return integer_zero_node;
1449 }
1450
1451 #if 0
1452 returns a structure like
1453 STRUCT (data STRUCT (flags ULONG,
1454 reclength ULONG,
1455 lowindex LONG,
1456 highindex LONG,
1457 association PTR,
1458 base ULONG,
1459 store_loc PTR,
1460 rectype LONG),
1461 this is followed by a
1462 TYPE_DECL __recordmode recordmode ? recordmode : void_type_node
1463 TYPE_DECL __indexmode indexmode ? indexmode : void_type_node
1464 CONST_DECL __dynamic dynamic ? integer_one_node : integer_zero_node
1465 #endif
1466
1467 static tree
1468 build_access_part ()
1469 {
1470 tree listbase, decl;
1471
1472 listbase = build_decl (FIELD_DECL, get_identifier ("flags"),
1473 long_unsigned_type_node);
1474 decl = build_decl (FIELD_DECL, get_identifier ("reclength"),
1475 long_unsigned_type_node);
1476 listbase = chainon (listbase, decl);
1477 decl = build_decl (FIELD_DECL, get_identifier ("lowindex"),
1478 long_unsigned_type_node);
1479 listbase = chainon (listbase, decl);
1480 decl = build_decl (FIELD_DECL, get_identifier ("highindex"),
1481 long_integer_type_node);
1482 listbase = chainon (listbase, decl);
1483 decl = build_decl (FIELD_DECL, get_identifier ("association"),
1484 ptr_type_node);
1485 listbase = chainon (listbase, decl);
1486 decl = build_decl (FIELD_DECL, get_identifier ("base"),
1487 long_unsigned_type_node);
1488 listbase = chainon (listbase, decl);
1489 decl = build_decl (FIELD_DECL, get_identifier ("storelocptr"),
1490 ptr_type_node);
1491 listbase = chainon (listbase, decl);
1492 decl = build_decl (FIELD_DECL, get_identifier ("rectype"),
1493 long_integer_type_node);
1494 listbase = chainon (listbase, decl);
1495 return build_chill_struct_type (listbase);
1496 }
1497
1498 tree
1499 build_access_mode (indexmode, recordmode, dynamic)
1500 tree indexmode;
1501 tree recordmode;
1502 int dynamic;
1503 {
1504 tree type, listbase, decl, datamode;
1505
1506 if (indexmode != NULL_TREE && TREE_CODE (indexmode) == ERROR_MARK)
1507 return error_mark_node;
1508 if (recordmode != NULL_TREE && TREE_CODE (recordmode) == ERROR_MARK)
1509 return error_mark_node;
1510
1511 datamode = build_access_part ();
1512
1513 type = make_node (RECORD_TYPE);
1514 listbase = build_decl (FIELD_DECL, get_identifier ("data"),
1515 datamode);
1516 TYPE_FIELDS (type) = listbase;
1517 decl = build_lang_decl (TYPE_DECL, get_identifier ("__recordmode"),
1518 recordmode == NULL_TREE ? void_type_node : recordmode);
1519 chainon (listbase, decl);
1520 decl = build_lang_decl (TYPE_DECL, get_identifier ("__indexmode"),
1521 indexmode == NULL_TREE ? void_type_node : indexmode);
1522 chainon (listbase, decl);
1523 decl = build_decl (CONST_DECL, get_identifier ("__dynamic"),
1524 integer_type_node);
1525 DECL_INITIAL (decl) = dynamic ? integer_one_node : integer_zero_node;
1526 chainon (listbase, decl);
1527 CH_IS_ACCESS_MODE (type) = 1;
1528 CH_TYPE_NONVALUE_P (type) = 1;
1529 return type;
1530 }
1531 \f
1532 #if 0
1533 returns a structure like:
1534 STRUCT (txt STRUCT (flags ULONG,
1535 text_record PTR,
1536 access_sub PTR,
1537 actual_index LONG),
1538 acc STRUCT (flags ULONG,
1539 reclength ULONG,
1540 lowindex LONG,
1541 highindex LONG,
1542 association PTR,
1543 base ULONG,
1544 store_loc PTR,
1545 rectype LONG),
1546 tloc CHARS(textlength) VARYING;
1547 )
1548 followed by
1549 TYPE_DECL __indexmode indexmode ? indexmode : void_type_node
1550 CONST_DECL __text_length
1551 CONST_DECL __dynamic dynamic ? integer_one_node : integer_zero_node
1552 #endif
1553 tree
1554 build_text_mode (textlength, indexmode, dynamic)
1555 tree textlength;
1556 tree indexmode;
1557 int dynamic;
1558 {
1559 tree txt, acc, listbase, decl, type, tltype;
1560 tree savedlength = textlength;
1561
1562 if (indexmode != NULL_TREE && TREE_CODE (indexmode) == ERROR_MARK)
1563 return error_mark_node;
1564 if (textlength == NULL_TREE || TREE_CODE (textlength) == ERROR_MARK)
1565 return error_mark_node;
1566
1567 /* build the structure */
1568 listbase = build_decl (FIELD_DECL, get_identifier ("flags"),
1569 long_unsigned_type_node);
1570 decl = build_decl (FIELD_DECL, get_identifier ("text_record"),
1571 ptr_type_node);
1572 listbase = chainon (listbase, decl);
1573 decl = build_decl (FIELD_DECL, get_identifier ("access_sub"),
1574 ptr_type_node);
1575 listbase = chainon (listbase, decl);
1576 decl = build_decl (FIELD_DECL, get_identifier ("actual_index"),
1577 long_integer_type_node);
1578 listbase = chainon (listbase, decl);
1579 txt = build_chill_struct_type (listbase);
1580
1581 acc = build_access_part ();
1582
1583 type = make_node (RECORD_TYPE);
1584 listbase = build_decl (FIELD_DECL, get_identifier ("txt"), txt);
1585 TYPE_FIELDS (type) = listbase;
1586 decl = build_decl (FIELD_DECL, get_identifier ("acc"), acc);
1587 chainon (listbase, decl);
1588 /* the text location */
1589 tltype = build_string_type (char_type_node, textlength);
1590 tltype = build_varying_struct (tltype);
1591 decl = build_decl (FIELD_DECL, get_identifier ("tloc"),
1592 tltype);
1593 chainon (listbase, decl);
1594 /* the index mode */
1595 decl = build_lang_decl (TYPE_DECL, get_identifier ("__indexmode"),
1596 indexmode == NULL_TREE ? void_type_node : indexmode);
1597 chainon (listbase, decl);
1598 /* save dynamic */
1599 decl = build_decl (CONST_DECL, get_identifier ("__textlength"),
1600 integer_type_node);
1601 if (TREE_CODE (textlength) == COMPONENT_REF)
1602 /* FIXME: we cannot use one and the same COMPONENT_REF twice, so build
1603 another one */
1604 savedlength = build_component_ref (TREE_OPERAND (textlength, 0),
1605 TREE_OPERAND (textlength, 1));
1606 DECL_INITIAL (decl) = savedlength;
1607 chainon (listbase, decl);
1608 /* save dynamic */
1609 decl = build_decl (CONST_DECL, get_identifier ("__dynamic"),
1610 integer_type_node);
1611 DECL_INITIAL (decl) = dynamic ? integer_one_node : integer_zero_node;
1612 chainon (listbase, decl);
1613 CH_IS_TEXT_MODE (type) = 1;
1614 CH_TYPE_NONVALUE_P (type) = 1;
1615 return type;
1616 }
1617
1618 tree
1619 check_text_length (length)
1620 tree length;
1621 {
1622 if (length == NULL_TREE || TREE_CODE (length) == ERROR_MARK)
1623 return length;
1624 if (TREE_TYPE (length) == NULL_TREE
1625 || !CH_SIMILAR (TREE_TYPE (length), integer_type_node))
1626 {
1627 error ("non-integral text length");
1628 return integer_one_node;
1629 }
1630 if (TREE_CODE (length) != INTEGER_CST)
1631 {
1632 error ("non-constant text length");
1633 return integer_one_node;
1634 }
1635 if (compare_int_csts (LE_EXPR, length, integer_zero_node))
1636 {
1637 error ("text length must be greater then 0");
1638 return integer_one_node;
1639 }
1640 return length;
1641 }
1642
1643 tree
1644 text_indexmode (text)
1645 tree text;
1646 {
1647 tree field;
1648
1649 if (text == NULL_TREE || TREE_CODE (text) == ERROR_MARK)
1650 return NULL_TREE;
1651 if (! CH_IS_TEXT_MODE (text))
1652 return NULL_TREE;
1653
1654 field = TYPE_FIELDS (text);
1655 for ( ; field != NULL_TREE; field = TREE_CHAIN (field))
1656 {
1657 if (TREE_CODE (field) == TYPE_DECL)
1658 return TREE_TYPE (field);
1659 }
1660 return void_type_node;
1661 }
1662
1663 tree
1664 text_dynamic (text)
1665 tree text;
1666 {
1667 tree field;
1668
1669 if (text == NULL_TREE || TREE_CODE (text) == ERROR_MARK)
1670 return NULL_TREE;
1671 if (! CH_IS_TEXT_MODE (text))
1672 return NULL_TREE;
1673
1674 field = TYPE_FIELDS (text);
1675 for ( ; field != NULL_TREE; field = TREE_CHAIN (field))
1676 {
1677 if (TREE_CODE (field) == CONST_DECL &&
1678 DECL_NAME (field) == get_identifier ("__dynamic"))
1679 return DECL_INITIAL (field);
1680 }
1681 return integer_zero_node;
1682 }
1683
1684 tree
1685 text_length (text)
1686 tree text;
1687 {
1688 tree field;
1689
1690 if (text == NULL_TREE || TREE_CODE (text) == ERROR_MARK)
1691 return NULL_TREE;
1692 if (! CH_IS_TEXT_MODE (text))
1693 return NULL_TREE;
1694
1695 field = TYPE_FIELDS (text);
1696 for ( ; field != NULL_TREE; field = TREE_CHAIN (field))
1697 {
1698 if (TREE_CODE (field) == CONST_DECL &&
1699 DECL_NAME (field) == get_identifier ("__textlength"))
1700 return DECL_INITIAL (field);
1701 }
1702 return integer_zero_node;
1703 }
1704
1705 static tree
1706 textlocation_mode (text)
1707 tree text;
1708 {
1709 tree field;
1710
1711 if (text == NULL_TREE || TREE_CODE (text) == ERROR_MARK)
1712 return NULL_TREE;
1713 if (! CH_IS_TEXT_MODE (text))
1714 return NULL_TREE;
1715
1716 field = TYPE_FIELDS (text);
1717 for ( ; field != NULL_TREE; field = TREE_CHAIN (field))
1718 {
1719 if (TREE_CODE (field) == FIELD_DECL &&
1720 DECL_NAME (field) == get_identifier ("tloc"))
1721 return TREE_TYPE (field);
1722 }
1723 return NULL_TREE;
1724 }
1725 \f
1726 static int
1727 check_assoc (assoc, argnum, errmsg)
1728 tree assoc;
1729 int argnum;
1730 char *errmsg;
1731 {
1732 if (assoc == NULL_TREE || TREE_CODE (assoc) == ERROR_MARK)
1733 return 0;
1734
1735 if (! CH_IS_ASSOCIATION_MODE (TREE_TYPE (assoc)))
1736 {
1737 error ("argument %d of %s must be of mode ASSOCIATION", argnum, errmsg);
1738 return 0;
1739 }
1740 if (! CH_LOCATION_P (assoc))
1741 {
1742 error ("argument %d of %s must be a location", argnum, errmsg);
1743 return 0;
1744 }
1745 return 1;
1746 }
1747
1748 tree
1749 build_chill_associate (assoc, fname, attr)
1750 tree assoc;
1751 tree fname;
1752 tree attr;
1753 {
1754 tree arg1 = NULL_TREE, arg2 = NULL_TREE, arg3 = NULL_TREE, arg4 = NULL_TREE,
1755 arg5 = NULL_TREE, arg6, arg7;
1756 int had_errors = 0;
1757 tree result;
1758
1759 /* make some checks */
1760 if (fname == NULL_TREE || TREE_CODE (fname) == ERROR_MARK)
1761 return error_mark_node;
1762
1763 /* check the association */
1764 if (! check_assoc (assoc, 1, "ASSOCIATION"))
1765 had_errors = 1;
1766 else
1767 /* build a pointer to the association */
1768 arg1 = force_addr_of (assoc);
1769
1770 /* check the filename, must be a string */
1771 if (CH_CHARS_TYPE_P (TREE_TYPE (fname)) ||
1772 (flag_old_strings && TREE_CODE (fname) == INTEGER_CST &&
1773 TREE_CODE (TREE_TYPE (fname)) == CHAR_TYPE))
1774 {
1775 if (int_size_in_bytes (TREE_TYPE (fname)) == 0)
1776 {
1777 error ("argument 2 of ASSOCIATE must not be an empty string");
1778 had_errors = 1;
1779 }
1780 else
1781 {
1782 arg2 = force_addr_of (fname);
1783 arg3 = size_in_bytes (TREE_TYPE (fname));
1784 }
1785 }
1786 else if (chill_varying_string_type_p (TREE_TYPE (fname)))
1787 {
1788 arg2 = force_addr_of (build_component_ref (fname, var_data_id));
1789 arg3 = build_component_ref (fname, var_length_id);
1790 }
1791 else
1792 {
1793 error ("argument 2 to ASSOCIATE must be a string");
1794 had_errors = 1;
1795 }
1796
1797 /* check attr argument, must be a string too */
1798 if (attr == NULL_TREE)
1799 {
1800 arg4 = null_pointer_node;
1801 arg5 = integer_zero_node;
1802 }
1803 else
1804 {
1805 attr = TREE_VALUE (attr);
1806 if (attr == NULL_TREE || TREE_CODE (attr) == ERROR_MARK)
1807 had_errors = 1;
1808 else
1809 {
1810 if (CH_CHARS_TYPE_P (TREE_TYPE (attr)) ||
1811 (flag_old_strings && TREE_CODE (attr) == INTEGER_CST &&
1812 TREE_CODE (TREE_TYPE (attr)) == CHAR_TYPE))
1813 {
1814 if (int_size_in_bytes (TREE_TYPE (attr)) == 0)
1815 {
1816 arg4 = null_pointer_node;
1817 arg5 = integer_zero_node;
1818 }
1819 else
1820 {
1821 arg4 = force_addr_of (attr);
1822 arg5 = size_in_bytes (TREE_TYPE (attr));
1823 }
1824 }
1825 else if (chill_varying_string_type_p (TREE_TYPE (attr)))
1826 {
1827 arg4 = force_addr_of (build_component_ref (attr, var_data_id));
1828 arg5 = build_component_ref (attr, var_length_id);
1829 }
1830 else
1831 {
1832 error ("argument 3 to ASSOCIATE must be a string");
1833 had_errors = 1;
1834 }
1835 }
1836 }
1837
1838 if (had_errors)
1839 return error_mark_node;
1840
1841 /* other arguments */
1842 arg6 = force_addr_of (get_chill_filename ());
1843 arg7 = get_chill_linenumber ();
1844
1845 result = build_chill_function_call (
1846 lookup_name (get_identifier ("__associate")),
1847 tree_cons (NULL_TREE, arg1,
1848 tree_cons (NULL_TREE, arg2,
1849 tree_cons (NULL_TREE, arg3,
1850 tree_cons (NULL_TREE, arg4,
1851 tree_cons (NULL_TREE, arg5,
1852 tree_cons (NULL_TREE, arg6,
1853 tree_cons (NULL_TREE, arg7, NULL_TREE))))))));
1854
1855 TREE_TYPE (result) = build_chill_pointer_type (TREE_TYPE (assoc));
1856 return result;
1857 }
1858
1859 static tree
1860 assoc_call (assoc, func, name)
1861 tree assoc;
1862 tree func;
1863 char *name;
1864 {
1865 tree arg1, arg2, arg3;
1866 tree result;
1867
1868 if (! check_assoc (assoc, 1, name))
1869 return error_mark_node;
1870
1871 arg1 = force_addr_of (assoc);
1872 arg2 = force_addr_of (get_chill_filename ());
1873 arg3 = get_chill_linenumber ();
1874
1875 result = build_chill_function_call (func,
1876 tree_cons (NULL_TREE, arg1,
1877 tree_cons (NULL_TREE, arg2,
1878 tree_cons (NULL_TREE, arg3, NULL_TREE))));
1879 return result;
1880 }
1881
1882 tree
1883 build_chill_isassociated (assoc)
1884 tree assoc;
1885 {
1886 tree result = assoc_call (assoc,
1887 lookup_name (get_identifier ("__isassociated")),
1888 "ISASSOCIATED");
1889 return result;
1890 }
1891
1892 tree
1893 build_chill_existing (assoc)
1894 tree assoc;
1895 {
1896 tree result = assoc_call (assoc,
1897 lookup_name (get_identifier ("__existing")),
1898 "EXISTING");
1899 return result;
1900 }
1901
1902 tree
1903 build_chill_readable (assoc)
1904 tree assoc;
1905 {
1906 tree result = assoc_call (assoc,
1907 lookup_name (get_identifier ("__readable")),
1908 "READABLE");
1909 return result;
1910 }
1911
1912 tree
1913 build_chill_writeable (assoc)
1914 tree assoc;
1915 {
1916 tree result = assoc_call (assoc,
1917 lookup_name (get_identifier ("__writeable")),
1918 "WRITEABLE");
1919 return result;
1920 }
1921
1922 tree
1923 build_chill_sequencible (assoc)
1924 tree assoc;
1925 {
1926 tree result = assoc_call (assoc,
1927 lookup_name (get_identifier ("__sequencible")),
1928 "SEQUENCIBLE");
1929 return result;
1930 }
1931
1932 tree
1933 build_chill_variable (assoc)
1934 tree assoc;
1935 {
1936 tree result = assoc_call (assoc,
1937 lookup_name (get_identifier ("__variable")),
1938 "VARIABLE");
1939 return result;
1940 }
1941
1942 tree
1943 build_chill_indexable (assoc)
1944 tree assoc;
1945 {
1946 tree result = assoc_call (assoc,
1947 lookup_name (get_identifier ("__indexable")),
1948 "INDEXABLE");
1949 return result;
1950 }
1951
1952 tree
1953 build_chill_dissociate (assoc)
1954 tree assoc;
1955 {
1956 tree result = assoc_call (assoc,
1957 lookup_name (get_identifier ("__dissociate")),
1958 "DISSOCIATE");
1959 return result;
1960 }
1961
1962 tree
1963 build_chill_create (assoc)
1964 tree assoc;
1965 {
1966 tree result = assoc_call (assoc,
1967 lookup_name (get_identifier ("__create")),
1968 "CREATE");
1969 return result;
1970 }
1971
1972 tree
1973 build_chill_delete (assoc)
1974 tree assoc;
1975 {
1976 tree result = assoc_call (assoc,
1977 lookup_name (get_identifier ("__delete")),
1978 "DELETE");
1979 return result;
1980 }
1981
1982 tree
1983 build_chill_modify (assoc, list)
1984 tree assoc;
1985 tree list;
1986 {
1987 tree arg1 = NULL_TREE, arg2 = NULL_TREE, arg3 = NULL_TREE, arg4 = NULL_TREE,
1988 arg5 = NULL_TREE, arg6, arg7;
1989 int had_errors = 0, numargs;
1990 tree fname = NULL_TREE, attr = NULL_TREE;
1991 tree result;
1992
1993 /* check the association */
1994 if (! check_assoc (assoc, 1, "MODIFY"))
1995 had_errors = 1;
1996 else
1997 arg1 = force_addr_of (assoc);
1998
1999 /* look how much arguments we have got */
2000 numargs = list_length (list);
2001 switch (numargs)
2002 {
2003 case 0:
2004 break;
2005 case 1:
2006 fname = TREE_VALUE (list);
2007 break;
2008 case 2:
2009 fname = TREE_VALUE (list);
2010 attr = TREE_VALUE (TREE_CHAIN (list));
2011 break;
2012 default:
2013 error ("Too many arguments in call to MODIFY");
2014 had_errors = 1;
2015 break;
2016 }
2017
2018 if (fname != NULL_TREE && fname != null_pointer_node)
2019 {
2020 if (CH_CHARS_TYPE_P (TREE_TYPE (fname)) ||
2021 (flag_old_strings && TREE_CODE (fname) == INTEGER_CST &&
2022 TREE_CODE (TREE_TYPE (fname)) == CHAR_TYPE))
2023 {
2024 if (int_size_in_bytes (TREE_TYPE (fname)) == 0)
2025 {
2026 error ("argument 2 of MODIFY must not be an empty string");
2027 had_errors = 1;
2028 }
2029 else
2030 {
2031 arg2 = force_addr_of (fname);
2032 arg3 = size_in_bytes (TREE_TYPE (fname));
2033 }
2034 }
2035 else if (chill_varying_string_type_p (TREE_TYPE (fname)))
2036 {
2037 arg2 = force_addr_of (build_component_ref (fname, var_data_id));
2038 arg3 = build_component_ref (fname, var_length_id);
2039 }
2040 else
2041 {
2042 error ("argument 2 to MODIFY must be a string");
2043 had_errors = 1;
2044 }
2045 }
2046 else
2047 {
2048 arg2 = null_pointer_node;
2049 arg3 = integer_zero_node;
2050 }
2051
2052 if (attr != NULL_TREE && attr != null_pointer_node)
2053 {
2054 if (CH_CHARS_TYPE_P (TREE_TYPE (attr)) ||
2055 (flag_old_strings && TREE_CODE (attr) == INTEGER_CST &&
2056 TREE_CODE (TREE_TYPE (attr)) == CHAR_TYPE))
2057 {
2058 if (int_size_in_bytes (TREE_TYPE (attr)) == 0)
2059 {
2060 arg4 = null_pointer_node;
2061 arg5 = integer_zero_node;
2062 }
2063 else
2064 {
2065 arg4 = force_addr_of (attr);
2066 arg5 = size_in_bytes (TREE_TYPE (attr));
2067 }
2068 }
2069 else if (chill_varying_string_type_p (TREE_TYPE (attr)))
2070 {
2071 arg4 = force_addr_of (build_component_ref (attr, var_data_id));
2072 arg5 = build_component_ref (attr, var_length_id);
2073 }
2074 else
2075 {
2076 error ("argument 3 to MODIFY must be a string");
2077 had_errors = 1;
2078 }
2079 }
2080 else
2081 {
2082 arg4 = null_pointer_node;
2083 arg5 = integer_zero_node;
2084 }
2085
2086 if (had_errors)
2087 return error_mark_node;
2088
2089 /* other arguments */
2090 arg6 = force_addr_of (get_chill_filename ());
2091 arg7 = get_chill_linenumber ();
2092
2093 result = build_chill_function_call (
2094 lookup_name (get_identifier ("__modify")),
2095 tree_cons (NULL_TREE, arg1,
2096 tree_cons (NULL_TREE, arg2,
2097 tree_cons (NULL_TREE, arg3,
2098 tree_cons (NULL_TREE, arg4,
2099 tree_cons (NULL_TREE, arg5,
2100 tree_cons (NULL_TREE, arg6,
2101 tree_cons (NULL_TREE, arg7, NULL_TREE))))))));
2102
2103 return result;
2104 }
2105 \f
2106 static int
2107 check_transfer (transfer, argnum, errmsg)
2108 tree transfer;
2109 int argnum;
2110 char *errmsg;
2111 {
2112 int result = 0;
2113
2114 if (transfer == NULL_TREE || TREE_CODE (transfer) == ERROR_MARK)
2115 return 0;
2116
2117 if (CH_IS_ACCESS_MODE (TREE_TYPE (transfer)))
2118 result = 1;
2119 else if (CH_IS_TEXT_MODE (TREE_TYPE (transfer)))
2120 result = 2;
2121 else
2122 {
2123 error ("argument %d of %s must be an ACCESS or TEXT mode", argnum, errmsg);
2124 return 0;
2125 }
2126 if (! CH_LOCATION_P (transfer))
2127 {
2128 error ("argument %d of %s must be a location", argnum, errmsg);
2129 return 0;
2130 }
2131 return result;
2132 }
2133
2134 /* define bits in an access/text flag word.
2135 NOTE: this must be consistent with runtime/iomodes.h */
2136 #define IO_TEXTLOCATION 0x80000000
2137 #define IO_INDEXED 0x00000001
2138 #define IO_TEXTIO 0x00000002
2139 #define IO_OUTOFFILE 0x00010000
2140 \f
2141 /* generated initialisation code for ACCESS and TEXT.
2142 functions gets called from do_decl. */
2143 void init_access_location (decl, type)
2144 tree decl;
2145 tree type;
2146 {
2147 tree recordmode = access_recordmode (type);
2148 tree indexmode = access_indexmode (type);
2149 int flags_init = 0;
2150 tree data = build_component_ref (decl, get_identifier ("data"));
2151 tree lowindex = integer_zero_node;
2152 tree highindex = integer_zero_node;
2153 tree rectype, reclen;
2154
2155 /* flag word */
2156 if (indexmode != NULL_TREE && indexmode != void_type_node)
2157 {
2158 flags_init |= IO_INDEXED;
2159 lowindex = convert (integer_type_node, TYPE_MIN_VALUE (indexmode));
2160 highindex = convert (integer_type_node, TYPE_MAX_VALUE (indexmode));
2161 }
2162
2163 expand_expr_stmt (
2164 build_chill_modify_expr (
2165 build_component_ref (data, get_identifier ("flags")),
2166 build_int_2 (flags_init, 0)));
2167
2168 /* record length */
2169 if (recordmode == NULL_TREE || recordmode == void_type_node)
2170 {
2171 reclen = integer_zero_node;
2172 rectype = integer_zero_node;
2173 }
2174 else if (chill_varying_string_type_p (recordmode))
2175 {
2176 tree fields = TYPE_FIELDS (recordmode);
2177 tree len1, len2;
2178
2179 /* don't count any padding bytes at end of varying */
2180 len1 = size_in_bytes (TREE_TYPE (fields));
2181 fields = TREE_CHAIN (fields);
2182 len2 = size_in_bytes (TREE_TYPE (fields));
2183 reclen = fold (build (PLUS_EXPR, long_integer_type_node, len1, len2));
2184 rectype = build_int_2 (2, 0);
2185 }
2186 else
2187 {
2188 reclen = size_in_bytes (recordmode);
2189 rectype = integer_one_node;
2190 }
2191 expand_expr_stmt (
2192 build_chill_modify_expr (
2193 build_component_ref (data, get_identifier ("reclength")), reclen));
2194
2195 /* record type */
2196 expand_expr_stmt (
2197 build_chill_modify_expr (
2198 build_component_ref (data, get_identifier ("rectype")), rectype));
2199
2200 /* the index */
2201 expand_expr_stmt (
2202 build_chill_modify_expr (
2203 build_component_ref (data, get_identifier ("lowindex")), lowindex));
2204 expand_expr_stmt (
2205 build_chill_modify_expr (
2206 build_component_ref (data, get_identifier ("highindex")), highindex));
2207
2208 /* association */
2209 expand_expr_stmt (
2210 build_chill_modify_expr (
2211 build_chill_component_ref (data, get_identifier ("association")),
2212 null_pointer_node));
2213
2214 /* storelocptr */
2215 expand_expr_stmt (
2216 build_chill_modify_expr (
2217 build_component_ref (data, get_identifier ("storelocptr")), null_pointer_node));
2218 }
2219
2220 void init_text_location (decl, type)
2221 tree decl;
2222 tree type;
2223 {
2224 tree indexmode = text_indexmode (type);
2225 unsigned long accessflags = 0;
2226 unsigned long textflags = IO_TEXTLOCATION;
2227 tree lowindex = integer_zero_node;
2228 tree highindex = integer_zero_node;
2229 tree data, tloc, tlocfields, len1, len2, reclen;
2230
2231 if (indexmode != NULL_TREE && indexmode != void_type_node)
2232 {
2233 accessflags |= IO_INDEXED;
2234 lowindex = convert (integer_type_node, TYPE_MIN_VALUE (indexmode));
2235 highindex = convert (integer_type_node, TYPE_MAX_VALUE (indexmode));
2236 }
2237
2238 tloc = build_component_ref (decl, get_identifier ("tloc"));
2239 /* fill access part of text location */
2240 data = build_component_ref (decl, get_identifier ("acc"));
2241 /* flag word */
2242 expand_expr_stmt (
2243 build_chill_modify_expr (
2244 build_component_ref (data, get_identifier ("flags")),
2245 build_int_2 (accessflags, 0)));
2246
2247 /* record length, don't count any padding bytes at end of varying */
2248 tlocfields = TYPE_FIELDS (TREE_TYPE (tloc));
2249 len1 = size_in_bytes (TREE_TYPE (tlocfields));
2250 tlocfields = TREE_CHAIN (tlocfields);
2251 len2 = size_in_bytes (TREE_TYPE (tlocfields));
2252 reclen = fold (build (PLUS_EXPR, long_integer_type_node, len1, len2));
2253 expand_expr_stmt (
2254 build_chill_modify_expr (
2255 build_component_ref (data, get_identifier ("reclength")),
2256 reclen));
2257
2258 /* the index */
2259 expand_expr_stmt (
2260 build_chill_modify_expr (
2261 build_component_ref (data, get_identifier ("lowindex")), lowindex));
2262 expand_expr_stmt (
2263 build_chill_modify_expr (
2264 build_component_ref (data, get_identifier ("highindex")), highindex));
2265
2266 /* association */
2267 expand_expr_stmt (
2268 build_chill_modify_expr (
2269 build_chill_component_ref (data, get_identifier ("association")),
2270 null_pointer_node));
2271
2272 /* storelocptr */
2273 expand_expr_stmt (
2274 build_chill_modify_expr (
2275 build_component_ref (data, get_identifier ("storelocptr")),
2276 null_pointer_node));
2277
2278 /* record type */
2279 expand_expr_stmt (
2280 build_chill_modify_expr (
2281 build_component_ref (data, get_identifier ("rectype")),
2282 build_int_2 (2, 0))); /* VaryingChars */
2283
2284 /* fill text part */
2285 data = build_component_ref (decl, get_identifier ("txt"));
2286 /* flag word */
2287 expand_expr_stmt (
2288 build_chill_modify_expr (
2289 build_component_ref (data, get_identifier ("flags")),
2290 build_int_2 (textflags, 0)));
2291
2292 /* pointer to text record */
2293 expand_expr_stmt (
2294 build_chill_modify_expr (
2295 build_component_ref (data, get_identifier ("text_record")),
2296 force_addr_of (tloc)));
2297
2298 /* pointer to the access */
2299 expand_expr_stmt (
2300 build_chill_modify_expr (
2301 build_component_ref (data, get_identifier ("access_sub")),
2302 force_addr_of (build_component_ref (decl, get_identifier ("acc")))));
2303
2304 /* actual length */
2305 expand_expr_stmt (
2306 build_chill_modify_expr (
2307 build_component_ref (data, get_identifier ("actual_index")),
2308 integer_zero_node));
2309
2310 /* length of text record */
2311 expand_expr_stmt (
2312 build_chill_modify_expr (
2313 build_component_ref (tloc, get_identifier (VAR_LENGTH)),
2314 integer_zero_node));
2315 }
2316 \f
2317 static int
2318 connect_process_optionals (optionals, whereptr, indexptr, indexmode)
2319 tree optionals;
2320 tree *whereptr;
2321 tree *indexptr;
2322 tree indexmode;
2323 {
2324 tree where = NULL_TREE, theindex = NULL_TREE;
2325 int had_errors = 0;
2326
2327 if (optionals != NULL_TREE)
2328 {
2329 /* get the where expression */
2330 where = TREE_VALUE (optionals);
2331 if (where == NULL_TREE || TREE_CODE (where) == ERROR_MARK)
2332 had_errors = 1;
2333 else
2334 {
2335 if (! CH_IS_WHERE_MODE (TREE_TYPE (where)))
2336 {
2337 error ("argument 4 of CONNECT must be of mode WHERE");
2338 had_errors = 1;
2339 }
2340 where = convert (integer_type_node, where);
2341 }
2342 optionals = TREE_CHAIN (optionals);
2343 }
2344 if (optionals != NULL_TREE)
2345 {
2346 theindex = TREE_VALUE (optionals);
2347 if (theindex == NULL_TREE || TREE_CODE (theindex) == ERROR_MARK)
2348 had_errors = 1;
2349 else
2350 {
2351 if (indexmode == void_type_node)
2352 {
2353 error ("index expression for ACCESS without index");
2354 had_errors = 1;
2355 }
2356 else if (! CH_COMPATIBLE (theindex, indexmode))
2357 {
2358 error ("incompatible index mode");
2359 had_errors = 1;
2360 }
2361 }
2362 }
2363 if (had_errors)
2364 return 0;
2365
2366 *whereptr = where;
2367 *indexptr = theindex;
2368 return 1;
2369 }
2370
2371 static tree
2372 connect_text (assoc, text, usage, optionals)
2373 tree assoc;
2374 tree text;
2375 tree usage;
2376 tree optionals;
2377 {
2378 tree where = NULL_TREE, theindex = NULL_TREE;
2379 tree indexmode = text_indexmode (TREE_TYPE (text));
2380 tree result, what_where, have_index, what_index;
2381
2382 /* process optionals */
2383 if (!connect_process_optionals (optionals, &where, &theindex, indexmode))
2384 return error_mark_node;
2385
2386 what_where = where == NULL_TREE ? integer_zero_node : where;
2387 have_index = theindex == NULL_TREE ? integer_zero_node
2388 : integer_one_node;
2389 what_index = theindex == NULL_TREE ? integer_zero_node
2390 : convert (integer_type_node, theindex);
2391 result = build_chill_function_call (
2392 lookup_name (get_identifier ("__connect")),
2393 tree_cons (NULL_TREE, force_addr_of (text),
2394 tree_cons (NULL_TREE, force_addr_of (assoc),
2395 tree_cons (NULL_TREE, convert (integer_type_node, usage),
2396 tree_cons (NULL_TREE, what_where,
2397 tree_cons (NULL_TREE, have_index,
2398 tree_cons (NULL_TREE, what_index,
2399 tree_cons (NULL_TREE, force_addr_of (get_chill_filename ()),
2400 tree_cons (NULL_TREE, get_chill_linenumber (),
2401 NULL_TREE)))))))));
2402 return result;
2403 }
2404
2405 static tree
2406 connect_access (assoc, transfer, usage, optionals)
2407 tree assoc;
2408 tree transfer;
2409 tree usage;
2410 tree optionals;
2411 {
2412 tree where = NULL_TREE, theindex = NULL_TREE;
2413 tree indexmode = access_indexmode (TREE_TYPE (transfer));
2414 tree result, what_where, have_index, what_index;
2415
2416 /* process the optionals */
2417 if (! connect_process_optionals (optionals, &where, &theindex, indexmode))
2418 return error_mark_node;
2419
2420 /* now the call */
2421 what_where = where == NULL_TREE ? integer_zero_node : where;
2422 have_index = theindex == NULL_TREE ? integer_zero_node : integer_one_node;
2423 what_index = theindex == NULL_TREE ? integer_zero_node : convert (integer_type_node, theindex);
2424 result = build_chill_function_call (
2425 lookup_name (get_identifier ("__connect")),
2426 tree_cons (NULL_TREE, force_addr_of (transfer),
2427 tree_cons (NULL_TREE, force_addr_of (assoc),
2428 tree_cons (NULL_TREE, convert (integer_type_node, usage),
2429 tree_cons (NULL_TREE, what_where,
2430 tree_cons (NULL_TREE, have_index,
2431 tree_cons (NULL_TREE, what_index,
2432 tree_cons (NULL_TREE, force_addr_of (get_chill_filename ()),
2433 tree_cons (NULL_TREE, get_chill_linenumber (),
2434 NULL_TREE)))))))));
2435 return result;
2436 }
2437
2438 tree
2439 build_chill_connect (transfer, assoc, usage, optionals)
2440 tree transfer;
2441 tree assoc;
2442 tree usage;
2443 tree optionals;
2444 {
2445 int had_errors = 0;
2446 int what = 0;
2447 tree result = error_mark_node;
2448
2449 if (! check_assoc (assoc, 2, "CONNECT"))
2450 had_errors = 1;
2451
2452 /* check usage */
2453 if (usage == NULL_TREE || TREE_CODE (usage) == ERROR_MARK)
2454 return error_mark_node;
2455
2456 if (! CH_IS_USAGE_MODE (TREE_TYPE (usage)))
2457 {
2458 error ("argument 3 to CONNECT must be of mode USAGE");
2459 had_errors = 1;
2460 }
2461 if (had_errors)
2462 return error_mark_node;
2463
2464 /* look what we have got */
2465 what = check_transfer (transfer, 1, "CONNECT");
2466 switch (what)
2467 {
2468 case 1:
2469 /* we have an ACCESS */
2470 result = connect_access (assoc, transfer, usage, optionals);
2471 break;
2472 case 2:
2473 /* we have a TEXT */
2474 result = connect_text (assoc, transfer, usage, optionals);
2475 break;
2476 default:
2477 result = error_mark_node;
2478 }
2479 return result;
2480 }
2481
2482 static int
2483 check_access (access, argnum, errmsg)
2484 tree access;
2485 int argnum;
2486 char *errmsg;
2487 {
2488 if (access == NULL_TREE || TREE_CODE (access) == ERROR_MARK)
2489 return 1;
2490
2491 if (! CH_IS_ACCESS_MODE (TREE_TYPE (access)))
2492 {
2493 error ("argument %d of %s must be of mode ACCESS", argnum, errmsg);
2494 return 0;
2495 }
2496 if (! CH_LOCATION_P (access))
2497 {
2498 error ("argument %d of %s must be a location", argnum, errmsg);
2499 return 0;
2500 }
2501 return 1;
2502 }
2503
2504 tree
2505 build_chill_readrecord (access, optionals)
2506 tree access;
2507 tree optionals;
2508 {
2509 int len;
2510 tree recordmode, indexmode, dynamic, result;
2511 tree index = NULL_TREE, location = NULL_TREE;
2512
2513 if (! check_access (access, 1, "READRECORD"))
2514 return error_mark_node;
2515
2516 recordmode = access_recordmode (TREE_TYPE (access));
2517 indexmode = access_indexmode (TREE_TYPE (access));
2518 dynamic = access_dynamic (TREE_TYPE (access));
2519
2520 /* process the optionals */
2521 len = list_length (optionals);
2522 if (indexmode != void_type_node)
2523 {
2524 /* we must have an index */
2525 if (!len)
2526 {
2527 error ("Too few arguments in call to `readrecord'");
2528 return error_mark_node;
2529 }
2530 index = TREE_VALUE (optionals);
2531 if (index == NULL_TREE || TREE_CODE (index) == ERROR_MARK)
2532 return error_mark_node;
2533 optionals = TREE_CHAIN (optionals);
2534 if (! CH_COMPATIBLE (index, indexmode))
2535 {
2536 error ("incompatible index mode");
2537 return error_mark_node;
2538 }
2539 }
2540
2541 /* check the record mode, if one */
2542 if (optionals != NULL_TREE)
2543 {
2544 location = TREE_VALUE (optionals);
2545 if (location == NULL_TREE || TREE_CODE (location) == ERROR_MARK)
2546 return error_mark_node;
2547 if (recordmode != void_type_node &&
2548 ! CH_COMPATIBLE (location, recordmode))
2549 {
2550
2551 error ("incompatible record mode");
2552 return error_mark_node;
2553 }
2554 if (TYPE_READONLY_PROPERTY (TREE_TYPE (location)))
2555 {
2556 error ("store location must not be READonly");
2557 return error_mark_node;
2558 }
2559 location = force_addr_of (location);
2560 }
2561 else
2562 location = null_pointer_node;
2563
2564 index = index == NULL_TREE ? integer_zero_node : convert (integer_type_node, index);
2565 result = build_chill_function_call (
2566 lookup_name (get_identifier ("__readrecord")),
2567 tree_cons (NULL_TREE, force_addr_of (access),
2568 tree_cons (NULL_TREE, index,
2569 tree_cons (NULL_TREE, location,
2570 tree_cons (NULL_TREE, force_addr_of (get_chill_filename ()),
2571 tree_cons (NULL_TREE, get_chill_linenumber (), NULL_TREE))))));
2572
2573 TREE_TYPE (result) = build_chill_pointer_type (recordmode);
2574 return result;
2575 }
2576
2577 tree
2578 build_chill_writerecord (access, optionals)
2579 tree access;
2580 tree optionals;
2581 {
2582 int had_errors = 0, len;
2583 tree recordmode, indexmode, dynamic;
2584 tree index = NULL_TREE, location = NULL_TREE;
2585 tree result;
2586
2587 if (! check_access (access, 1, "WRITERECORD"))
2588 return error_mark_node;
2589
2590 recordmode = access_recordmode (TREE_TYPE (access));
2591 indexmode = access_indexmode (TREE_TYPE (access));
2592 dynamic = access_dynamic (TREE_TYPE (access));
2593
2594 /* process the optionals */
2595 len = list_length (optionals);
2596 if (indexmode != void_type_node && len != 2)
2597 {
2598 error ("Too few arguments in call to `writerecord'");
2599 return error_mark_node;
2600 }
2601 if (indexmode != void_type_node)
2602 {
2603 index = TREE_VALUE (optionals);
2604 if (index == NULL_TREE || TREE_CODE (index) == ERROR_MARK)
2605 return error_mark_node;
2606 location = TREE_VALUE (TREE_CHAIN (optionals));
2607 if (location == NULL_TREE || TREE_CODE (location) == ERROR_MARK)
2608 return error_mark_node;
2609 }
2610 else
2611 location = TREE_VALUE (optionals);
2612
2613 /* check the index */
2614 if (indexmode != void_type_node)
2615 {
2616 if (! CH_COMPATIBLE (index, indexmode))
2617 {
2618 error ("incompatible index mode");
2619 had_errors = 1;
2620 }
2621 }
2622 /* check the record mode */
2623 if (recordmode == void_type_node)
2624 {
2625 error ("transfer to ACCESS without record mode");
2626 had_errors = 1;
2627 }
2628 else if (! CH_COMPATIBLE (location, recordmode))
2629 {
2630 error ("incompatible record mode");
2631 had_errors = 1;
2632 }
2633 if (had_errors)
2634 return error_mark_node;
2635
2636 index = index == NULL_TREE ? integer_zero_node : convert (integer_type_node, index);
2637
2638 result = build_chill_function_call (
2639 lookup_name (get_identifier ("__writerecord")),
2640 tree_cons (NULL_TREE, force_addr_of (access),
2641 tree_cons (NULL_TREE, index,
2642 tree_cons (NULL_TREE, force_addr_of (location),
2643 tree_cons (NULL_TREE, size_in_bytes (TREE_TYPE (location)),
2644 tree_cons (NULL_TREE, force_addr_of (get_chill_filename ()),
2645 tree_cons (NULL_TREE, get_chill_linenumber (), NULL_TREE)))))));
2646 return result;
2647 }
2648
2649 tree
2650 build_chill_disconnect (transfer)
2651 tree transfer;
2652 {
2653 tree result;
2654
2655 if (! check_transfer (transfer, 1, "DISCONNECT"))
2656 return error_mark_node;
2657 result = build_chill_function_call (
2658 lookup_name (get_identifier ("__disconnect")),
2659 tree_cons (NULL_TREE, force_addr_of (transfer),
2660 tree_cons (NULL_TREE, force_addr_of (get_chill_filename ()),
2661 tree_cons (NULL_TREE, get_chill_linenumber (), NULL_TREE))));
2662 return result;
2663 }
2664
2665 tree
2666 build_chill_getassociation (transfer)
2667 tree transfer;
2668 {
2669 tree result;
2670
2671 if (! check_transfer (transfer, 1, "GETASSOCIATION"))
2672 return error_mark_node;
2673
2674 result = build_chill_function_call (
2675 lookup_name (get_identifier ("__getassociation")),
2676 tree_cons (NULL_TREE, force_addr_of (transfer),
2677 tree_cons (NULL_TREE, force_addr_of (get_chill_filename ()),
2678 tree_cons (NULL_TREE, get_chill_linenumber (), NULL_TREE))));
2679 TREE_TYPE (result) = build_chill_pointer_type (association_type_node);
2680 return result;
2681 }
2682
2683 tree
2684 build_chill_getusage (transfer)
2685 tree transfer;
2686 {
2687 tree result;
2688
2689 if (! check_transfer (transfer, 1, "GETUSAGE"))
2690 return error_mark_node;
2691
2692 result = build_chill_function_call (
2693 lookup_name (get_identifier ("__getusage")),
2694 tree_cons (NULL_TREE, force_addr_of (transfer),
2695 tree_cons (NULL_TREE, force_addr_of (get_chill_filename ()),
2696 tree_cons (NULL_TREE, get_chill_linenumber (), NULL_TREE))));
2697 TREE_TYPE (result) = usage_type_node;
2698 return result;
2699 }
2700
2701 tree
2702 build_chill_outoffile (transfer)
2703 tree transfer;
2704 {
2705 tree result;
2706
2707 if (! check_transfer (transfer, 1, "OUTOFFILE"))
2708 return error_mark_node;
2709
2710 result = build_chill_function_call (
2711 lookup_name (get_identifier ("__outoffile")),
2712 tree_cons (NULL_TREE, force_addr_of (transfer),
2713 tree_cons (NULL_TREE, force_addr_of (get_chill_filename ()),
2714 tree_cons (NULL_TREE, get_chill_linenumber (), NULL_TREE))));
2715 return result;
2716 }
2717 \f
2718 static int
2719 check_text (text, argnum, errmsg)
2720 tree text;
2721 int argnum;
2722 char *errmsg;
2723 {
2724 if (text == NULL_TREE || TREE_CODE (text) == ERROR_MARK)
2725 return 0;
2726 if (! CH_IS_TEXT_MODE (TREE_TYPE (text)))
2727 {
2728 error ("argument %d of %s must be of mode TEXT", argnum, errmsg);
2729 return 0;
2730 }
2731 if (! CH_LOCATION_P (text))
2732 {
2733 error ("argument %d of %s must be a location", argnum, errmsg);
2734 return 0;
2735 }
2736 return 1;
2737 }
2738
2739 tree
2740 build_chill_eoln (text)
2741 tree text;
2742 {
2743 tree result;
2744
2745 if (! check_text (text, 1, "EOLN"))
2746 return error_mark_node;
2747
2748 result = build_chill_function_call (
2749 lookup_name (get_identifier ("__eoln")),
2750 tree_cons (NULL_TREE, force_addr_of (text),
2751 tree_cons (NULL_TREE, force_addr_of (get_chill_filename ()),
2752 tree_cons (NULL_TREE, get_chill_linenumber (), NULL_TREE))));
2753 return result;
2754 }
2755
2756 tree
2757 build_chill_gettextindex (text)
2758 tree text;
2759 {
2760 tree result;
2761
2762 if (! check_text (text, 1, "GETTEXTINDEX"))
2763 return error_mark_node;
2764
2765 result = build_chill_function_call (
2766 lookup_name (get_identifier ("__gettextindex")),
2767 tree_cons (NULL_TREE, force_addr_of (text),
2768 tree_cons (NULL_TREE, force_addr_of (get_chill_filename ()),
2769 tree_cons (NULL_TREE, get_chill_linenumber (), NULL_TREE))));
2770 return result;
2771 }
2772
2773 tree
2774 build_chill_gettextrecord (text)
2775 tree text;
2776 {
2777 tree textmode, result;
2778
2779 if (! check_text (text, 1, "GETTEXTRECORD"))
2780 return error_mark_node;
2781
2782 textmode = textlocation_mode (TREE_TYPE (text));
2783 if (textmode == NULL_TREE)
2784 {
2785 error ("TEXT doesn't have a location"); /* FIXME */
2786 return error_mark_node;
2787 }
2788 result = build_chill_function_call (
2789 lookup_name (get_identifier ("__gettextrecord")),
2790 tree_cons (NULL_TREE, force_addr_of (text),
2791 tree_cons (NULL_TREE, force_addr_of (get_chill_filename ()),
2792 tree_cons (NULL_TREE, get_chill_linenumber (), NULL_TREE))));
2793 TREE_TYPE (result) = build_chill_pointer_type (textmode);
2794 CH_DERIVED_FLAG (result) = 1;
2795 return result;
2796 }
2797
2798 tree
2799 build_chill_gettextaccess (text)
2800 tree text;
2801 {
2802 tree access, refaccess, acc, decl, listbase;
2803 tree tlocmode, indexmode, dynamic;
2804 tree result;
2805 extern int maximum_field_alignment;
2806 int save_maximum_field_alignment = maximum_field_alignment;
2807
2808 if (! check_text (text, 1, "GETTEXTACCESS"))
2809 return error_mark_node;
2810
2811 tlocmode = textlocation_mode (TREE_TYPE (text));
2812 indexmode = text_indexmode (TREE_TYPE (text));
2813 dynamic = text_dynamic (TREE_TYPE (text));
2814
2815 /* we have to build a type for the access */
2816 acc = build_access_part ();
2817 access = make_node (RECORD_TYPE);
2818 listbase = build_decl (FIELD_DECL, get_identifier ("data"), acc);
2819 TYPE_FIELDS (access) = listbase;
2820 decl = build_lang_decl (TYPE_DECL, get_identifier ("__recordmode"),
2821 tlocmode);
2822 chainon (listbase, decl);
2823 decl = build_lang_decl (TYPE_DECL, get_identifier ("__indexmode"),
2824 indexmode);
2825 chainon (listbase, decl);
2826 decl = build_decl (CONST_DECL, get_identifier ("__dynamic"),
2827 integer_type_node);
2828 DECL_INITIAL (decl) = dynamic;
2829 chainon (listbase, decl);
2830 maximum_field_alignment = 0;
2831 layout_chill_struct_type (access);
2832 maximum_field_alignment = save_maximum_field_alignment;
2833 CH_IS_ACCESS_MODE (access) = 1;
2834 CH_TYPE_NONVALUE_P (access) = 1;
2835
2836 refaccess = build_chill_pointer_type (access);
2837
2838 result = build_chill_function_call (
2839 lookup_name (get_identifier ("__gettextaccess")),
2840 tree_cons (NULL_TREE, force_addr_of (text),
2841 tree_cons (NULL_TREE, force_addr_of (get_chill_filename ()),
2842 tree_cons (NULL_TREE, get_chill_linenumber (), NULL_TREE))));
2843 TREE_TYPE (result) = refaccess;
2844 CH_DERIVED_FLAG (result) = 1;
2845 return result;
2846 }
2847
2848 tree
2849 build_chill_settextindex (text, expr)
2850 tree text;
2851 tree expr;
2852 {
2853 tree result;
2854
2855 if (! check_text (text, 1, "SETTEXTINDEX"))
2856 return error_mark_node;
2857 if (expr == NULL_TREE || TREE_CODE (expr) == ERROR_MARK)
2858 return error_mark_node;
2859 result = build_chill_function_call (
2860 lookup_name (get_identifier ("__settextindex")),
2861 tree_cons (NULL_TREE, force_addr_of (text),
2862 tree_cons (NULL_TREE, expr,
2863 tree_cons (NULL_TREE, force_addr_of (get_chill_filename ()),
2864 tree_cons (NULL_TREE, get_chill_linenumber (), NULL_TREE)))));
2865 return result;
2866 }
2867
2868 tree
2869 build_chill_settextaccess (text, access)
2870 tree text;
2871 tree access;
2872 {
2873 tree result;
2874 tree textindexmode, accessindexmode;
2875 tree textrecordmode, accessrecordmode;
2876
2877 if (! check_text (text, 1, "SETTEXTACCESS"))
2878 return error_mark_node;
2879 if (! check_access (access, 2, "SETTEXTACCESS"))
2880 return error_mark_node;
2881
2882 textindexmode = text_indexmode (TREE_TYPE (text));
2883 accessindexmode = access_indexmode (TREE_TYPE (access));
2884 if (textindexmode != accessindexmode)
2885 {
2886 if (! chill_read_compatible (textindexmode, accessindexmode))
2887 {
2888 error ("incompatible index mode for SETETEXTACCESS");
2889 return error_mark_node;
2890 }
2891 }
2892 textrecordmode = textlocation_mode (TREE_TYPE (text));
2893 accessrecordmode = access_recordmode (TREE_TYPE (access));
2894 if (textrecordmode != accessrecordmode)
2895 {
2896 if (! chill_read_compatible (textrecordmode, accessrecordmode))
2897 {
2898 error ("incompatible record mode for SETTEXTACCESS");
2899 return error_mark_node;
2900 }
2901 }
2902 result = build_chill_function_call (
2903 lookup_name (get_identifier ("__settextaccess")),
2904 tree_cons (NULL_TREE, force_addr_of (text),
2905 tree_cons (NULL_TREE, force_addr_of (access),
2906 tree_cons (NULL_TREE, force_addr_of (get_chill_filename ()),
2907 tree_cons (NULL_TREE, get_chill_linenumber (), NULL_TREE)))));
2908 return result;
2909 }
2910
2911 tree
2912 build_chill_settextrecord (text, charloc)
2913 tree text;
2914 tree charloc;
2915 {
2916 tree result;
2917 int had_errors = 0;
2918 tree tlocmode;
2919
2920 if (! check_text (text, 1, "SETTEXTRECORD"))
2921 return error_mark_node;
2922 if (charloc == NULL_TREE || TREE_CODE (charloc) == ERROR_MARK)
2923 return error_mark_node;
2924
2925 /* check the location */
2926 if (! CH_LOCATION_P (charloc))
2927 {
2928 error ("parameter 2 must be a location");
2929 return error_mark_node;
2930 }
2931 tlocmode = textlocation_mode (TREE_TYPE (text));
2932 if (! chill_varying_string_type_p (TREE_TYPE (charloc)))
2933 had_errors = 1;
2934 else if (int_size_in_bytes (tlocmode) != int_size_in_bytes (TREE_TYPE (charloc)))
2935 had_errors = 1;
2936 if (had_errors)
2937 {
2938 error ("incompatible modes in parameter 2");
2939 return error_mark_node;
2940 }
2941 result = build_chill_function_call (
2942 lookup_name (get_identifier ("__settextrecord")),
2943 tree_cons (NULL_TREE, force_addr_of (text),
2944 tree_cons (NULL_TREE, force_addr_of (charloc),
2945 tree_cons (NULL_TREE, force_addr_of (get_chill_filename ()),
2946 tree_cons (NULL_TREE, get_chill_linenumber (), NULL_TREE)))));
2947 return result;
2948 }
2949 \f
2950 /* process iolist for READ- and WRITETEXT */
2951
2952 /* function walks through types as long as they are ranges,
2953 returns the type and min- and max-value form starting type.
2954 */
2955
2956 static tree
2957 get_final_type_and_range (item, low, high)
2958 tree item;
2959 tree *low;
2960 tree *high;
2961 {
2962 tree wrk = item;
2963
2964 *low = TYPE_MIN_VALUE (wrk);
2965 *high = TYPE_MAX_VALUE (wrk);
2966 while (TREE_CODE (wrk) == INTEGER_TYPE &&
2967 TREE_TYPE (wrk) != NULL_TREE &&
2968 TREE_CODE (TREE_TYPE (wrk)) == INTEGER_TYPE &&
2969 TREE_TYPE (TREE_TYPE (wrk)) != NULL_TREE)
2970 wrk = TREE_TYPE (wrk);
2971
2972 return (TREE_TYPE (wrk));
2973 }
2974
2975 static void
2976 process_io_list (exprlist, iolist_addr, iolist_length, iolist_rtx, do_read,
2977 argoffset)
2978 tree exprlist;
2979 tree *iolist_addr;
2980 tree *iolist_length;
2981 rtx *iolist_rtx;
2982 int do_read;
2983 int argoffset;
2984 {
2985 tree idxlist;
2986 int idxcnt;
2987 int iolen;
2988 tree iolisttype, iolist;
2989
2990 if (exprlist == NULL_TREE)
2991 return;
2992
2993 iolen = list_length (exprlist);
2994
2995 /* build indexlist for the io list */
2996 idxlist = build_tree_list (NULL_TREE,
2997 build_chill_range_type (NULL_TREE,
2998 integer_one_node,
2999 build_int_2 (iolen, 0)));
3000
3001 /* build the io-list type */
3002 iolisttype = build_chill_array_type (TREE_TYPE (chill_io_list_type),
3003 idxlist, 0, NULL_TREE);
3004
3005 /* declare the iolist */
3006 iolist = build_decl (VAR_DECL, get_unique_identifier (do_read ? "RDTEXT" : "WRTEXT"),
3007 iolisttype);
3008
3009 /* we want to get a variable which gets marked unused after
3010 the function call, This is a little bit tricky cause the
3011 address of this variable will be taken and therefor the variable
3012 gets moved out one level. However, we REALLY don't need this
3013 variable again. Solution: push 2 levels and do pop and free
3014 twice at the end. */
3015 push_temp_slots ();
3016 push_temp_slots ();
3017 *iolist_rtx = assign_temp (TREE_TYPE (iolist), 0, 1, 0);
3018 DECL_RTL (iolist) = *iolist_rtx;
3019
3020 /* process the exprlist */
3021 idxcnt = 1;
3022 while (exprlist != NULL_TREE)
3023 {
3024 tree item = TREE_VALUE (exprlist);
3025 tree idx = build_int_2 (idxcnt++, 0);
3026 char *fieldname = 0;
3027 char *enumname = 0;
3028 tree array_ref = build_chill_array_ref_1 (iolist, idx);
3029 tree item_type;
3030 tree range_low = NULL_TREE, range_high = NULL_TREE;
3031 int have_range = 0;
3032 tree item_addr = null_pointer_node;
3033 int referable = 0;
3034 int readonly = 0;
3035
3036 /* next value in exprlist */
3037 exprlist = TREE_CHAIN (exprlist);
3038 if (item == NULL_TREE || TREE_CODE (item) == ERROR_MARK)
3039 continue;
3040
3041 item_type = TREE_TYPE (item);
3042 if (item_type == NULL_TREE)
3043 {
3044 if (TREE_CODE (item) == COND_EXPR || TREE_CODE (item) == CASE_EXPR)
3045 error ("conditional expression not allowed in this context");
3046 else
3047 error ("untyped expression as argument %d", idxcnt + 1 + argoffset);
3048 continue;
3049 }
3050 else if (TREE_CODE (item_type) == ERROR_MARK)
3051 continue;
3052
3053 if (TREE_CODE (item_type) == REFERENCE_TYPE)
3054 {
3055 item_type = TREE_TYPE (item_type);
3056 item = convert (item_type, item);
3057 }
3058
3059 /* check for a range */
3060 if (TREE_CODE (item_type) == INTEGER_TYPE &&
3061 TREE_TYPE (item_type) != NULL_TREE)
3062 {
3063 /* we have a range. NOTE, however, on writetext we don't process ranges */
3064 item_type = get_final_type_and_range (item_type,
3065 &range_low, &range_high);
3066 have_range = 1;
3067 }
3068
3069 readonly = TYPE_READONLY_PROPERTY (item_type);
3070 referable = CH_REFERABLE (item);
3071 if (referable)
3072 item_addr = force_addr_of (item);
3073 /* if we are in read and have readonly we can't do this */
3074 if (readonly && do_read)
3075 {
3076 item_addr = null_pointer_node;
3077 referable = 0;
3078 }
3079
3080 /* process different types */
3081 if (TREE_CODE (item_type) == INTEGER_TYPE)
3082 {
3083 int type_size = TREE_INT_CST_LOW (TYPE_SIZE (item_type));
3084 tree to_assign = NULL_TREE;
3085
3086 if (do_read && referable)
3087 {
3088 /* process an integer in case of READTEXT and expression is
3089 referable and not READONLY */
3090 to_assign = item_addr;
3091 if (have_range)
3092 {
3093 /* do it for a range */
3094 tree t, __forxx, __ptr, __low, __high;
3095 tree what_upper, what_lower;
3096
3097 /* determine the name in the union of lower and upper */
3098 if (TREE_UNSIGNED (item_type))
3099 fieldname = "_ulong";
3100 else
3101 fieldname = "_slong";
3102
3103 switch (type_size)
3104 {
3105 case 8:
3106 if (TREE_UNSIGNED (item_type))
3107 enumname = "__IO_UByteRangeLoc";
3108 else
3109 enumname = "__IO_ByteRangeLoc";
3110 break;
3111 case 16:
3112 if (TREE_UNSIGNED (item_type))
3113 enumname = "__IO_UIntRangeLoc";
3114 else
3115 enumname = "__IO_IntRangeLoc";
3116 break;
3117 case 32:
3118 if (TREE_UNSIGNED (item_type))
3119 enumname = "__IO_ULongRangeLoc";
3120 else
3121 enumname = "__IO_LongRangeLoc";
3122 break;
3123 default:
3124 error ("Cannot process %d bits integer for READTEXT argument %d.",
3125 type_size, idxcnt + 1 + argoffset);
3126 continue;
3127 }
3128
3129 /* set up access to structure */
3130 t = build_component_ref (array_ref,
3131 get_identifier ("__t"));
3132 __forxx = build_component_ref (t, get_identifier ("__locintrange"));
3133 __ptr = build_component_ref (__forxx, get_identifier ("ptr"));
3134 __low = build_component_ref (__forxx, get_identifier ("lower"));
3135 what_lower = build_component_ref (__low, get_identifier (fieldname));
3136 __high = build_component_ref (__forxx, get_identifier ("upper"));
3137 what_upper = build_component_ref (__high, get_identifier (fieldname));
3138
3139 /* do the assignments */
3140 expand_assignment (__ptr, item_addr, 0, 0);
3141 expand_assignment (what_lower, range_low, 0, 0);
3142 expand_assignment (what_upper, range_high, 0, 0);
3143 fieldname = 0;
3144 }
3145 else
3146 {
3147 /* no range */
3148 fieldname = "__locint";
3149 switch (type_size)
3150 {
3151 case 8:
3152 if (TREE_UNSIGNED (item_type))
3153 enumname = "__IO_UByteLoc";
3154 else
3155 enumname = "__IO_ByteLoc";
3156 break;
3157 case 16:
3158 if (TREE_UNSIGNED (item_type))
3159 enumname = "__IO_UIntLoc";
3160 else
3161 enumname = "__IO_IntLoc";
3162 break;
3163 case 32:
3164 if (TREE_UNSIGNED (item_type))
3165 enumname = "__IO_ULongLoc";
3166 else
3167 enumname = "__IO_LongLoc";
3168 break;
3169 default:
3170 error ("Cannot process %d bits integer for READTEXT argument %d.",
3171 type_size, idxcnt + 1 + argoffset);
3172 continue;
3173 }
3174 }
3175 }
3176 else
3177 {
3178 /* process an integer in case of WRITETEXT */
3179 to_assign = item;
3180 switch (type_size)
3181 {
3182 case 8:
3183 if (TREE_UNSIGNED (item_type))
3184 {
3185 enumname = "__IO_UByteVal";
3186 fieldname = "__valubyte";
3187 }
3188 else
3189 {
3190 enumname = "__IO_ByteVal";
3191 fieldname = "__valbyte";
3192 }
3193 break;
3194 case 16:
3195 if (TREE_UNSIGNED (item_type))
3196 {
3197 enumname = "__IO_UIntVal";
3198 fieldname = "__valuint";
3199 }
3200 else
3201 {
3202 enumname = "__IO_IntVal";
3203 fieldname = "__valint";
3204 }
3205 break;
3206 case 32:
3207 try_long:
3208 if (TREE_UNSIGNED (item_type))
3209 {
3210 enumname = "__IO_ULongVal";
3211 fieldname = "__valulong";
3212 }
3213 else
3214 {
3215 enumname = "__IO_LongVal";
3216 fieldname = "__vallong";
3217 }
3218 break;
3219 case 64:
3220 /* convert it back to {unsigned}long. */
3221 if (TREE_UNSIGNED (item_type))
3222 item_type = long_unsigned_type_node;
3223 else
3224 item_type = long_integer_type_node;
3225 item = convert (item_type, item);
3226 goto try_long;
3227 default:
3228 /* This kludge is because the lexer gives literals
3229 the type long_long_{integer,unsigned}_type_node. */
3230 if (TREE_CODE (item) == INTEGER_CST)
3231 {
3232 if (int_fits_type_p (item, long_integer_type_node))
3233 {
3234 item_type = long_integer_type_node;
3235 item = convert (item_type, item);
3236 goto try_long;
3237 }
3238 if (int_fits_type_p (item, long_unsigned_type_node))
3239 {
3240 item_type = long_unsigned_type_node;
3241 item = convert (item_type, item);
3242 goto try_long;
3243 }
3244 }
3245 error ("Cannot process %d bits integer WRITETEXT argument %d.",
3246 type_size, idxcnt + 1 + argoffset);
3247 continue;
3248 }
3249 }
3250 if (fieldname)
3251 {
3252 tree t, __forxx;
3253
3254 t = build_component_ref (array_ref,
3255 get_identifier ("__t"));
3256 __forxx = build_component_ref (t, get_identifier (fieldname));
3257 expand_assignment (__forxx, to_assign, 0, 0);
3258 }
3259 }
3260 else if (TREE_CODE (item_type) == CHAR_TYPE)
3261 {
3262 tree to_assign = NULL_TREE;
3263
3264 if (do_read && readonly)
3265 {
3266 error ("argument %d is READonly", idxcnt + 1 + argoffset);
3267 continue;
3268 }
3269 if (do_read)
3270 {
3271 if (! referable)
3272 {
3273 error ("argument %d must be referable", idxcnt + 1 + argoffset);
3274 continue;
3275 }
3276 if (have_range)
3277 {
3278 tree t, forxx, ptr, lower, upper;
3279
3280 t = build_component_ref (array_ref, get_identifier ("__t"));
3281 forxx = build_component_ref (t, get_identifier ("__loccharrange"));
3282 ptr = build_component_ref (forxx, get_identifier ("ptr"));
3283 lower = build_component_ref (forxx, get_identifier ("lower"));
3284 upper = build_component_ref (forxx, get_identifier ("upper"));
3285 expand_assignment (ptr, item_addr, 0, 0);
3286 expand_assignment (lower, range_low, 0, 0);
3287 expand_assignment (upper, range_high, 0, 0);
3288
3289 fieldname = 0;
3290 enumname = "__IO_CharRangeLoc";
3291 }
3292 else
3293 {
3294 to_assign = item_addr;
3295 fieldname = "__locchar";
3296 enumname = "__IO_CharLoc";
3297 }
3298 }
3299 else
3300 {
3301 to_assign = item;
3302 enumname = "__IO_CharVal";
3303 fieldname = "__valchar";
3304 }
3305
3306 if (fieldname)
3307 {
3308 tree t, forxx;
3309
3310 t = build_component_ref (array_ref, get_identifier ("__t"));
3311 forxx = build_component_ref (t, get_identifier (fieldname));
3312 expand_assignment (forxx, to_assign, 0, 0);
3313 }
3314 }
3315 else if (TREE_CODE (item_type) == BOOLEAN_TYPE)
3316 {
3317 tree to_assign = NULL_TREE;
3318
3319 if (do_read && readonly)
3320 {
3321 error ("argument %d is READonly", idxcnt + 1 + argoffset);
3322 continue;
3323 }
3324 if (do_read)
3325 {
3326 if (! referable)
3327 {
3328 error ("argument %d must be referable", idxcnt + 1 + argoffset);
3329 continue;
3330 }
3331 if (have_range)
3332 {
3333 tree t, forxx, ptr, lower, upper;
3334
3335 t = build_component_ref (array_ref, get_identifier ("__t"));
3336 forxx = build_component_ref (t, get_identifier ("__locboolrange"));
3337 ptr = build_component_ref (forxx, get_identifier ("ptr"));
3338 lower = build_component_ref (forxx, get_identifier ("lower"));
3339 upper = build_component_ref (forxx, get_identifier ("upper"));
3340 expand_assignment (ptr, item_addr, 0, 0);
3341 expand_assignment (lower, range_low, 0, 0);
3342 expand_assignment (upper, range_high, 0, 0);
3343
3344 fieldname = 0;
3345 enumname = "__IO_BoolRangeLoc";
3346 }
3347 else
3348 {
3349 to_assign = item_addr;
3350 fieldname = "__locbool";
3351 enumname = "__IO_BoolLoc";
3352 }
3353 }
3354 else
3355 {
3356 to_assign = item;
3357 enumname = "__IO_BoolVal";
3358 fieldname = "__valbool";
3359 }
3360 if (fieldname)
3361 {
3362 tree t, forxx;
3363
3364 t = build_component_ref (array_ref, get_identifier ("__t"));
3365 forxx = build_component_ref (t, get_identifier (fieldname));
3366 expand_assignment (forxx, to_assign, 0, 0);
3367 }
3368 }
3369 else if (TREE_CODE (item_type) == ENUMERAL_TYPE)
3370 {
3371 /* process an enum */
3372 tree table_name;
3373 tree context_of_type;
3374 tree t;
3375
3376 /* determine the context of the type.
3377 if TYPE_NAME (item_type) == NULL_TREE
3378 if TREE_CODE (item) == INTEGER_CST
3379 context = NULL_TREE -- this is wrong but should work for now
3380 else
3381 context = DECL_CONTEXT (item)
3382 else
3383 context = DECL_CONTEXT (TYPE_NAME (item_type)) */
3384
3385 if (TYPE_NAME (item_type) == NULL_TREE)
3386 {
3387 if (TREE_CODE (item) == INTEGER_CST)
3388 context_of_type = NULL_TREE;
3389 else
3390 context_of_type = DECL_CONTEXT (item);
3391 }
3392 else
3393 context_of_type = DECL_CONTEXT (TYPE_NAME (item_type));
3394
3395 table_name = add_enum_to_list (item_type, context_of_type);
3396 t = build_component_ref (array_ref, get_identifier ("__t"));
3397
3398 if (do_read && readonly)
3399 {
3400 error ("argument %d is READonly", idxcnt + 1 + argoffset);
3401 continue;
3402 }
3403 if (do_read)
3404 {
3405 if (! referable)
3406 {
3407 error ("argument %d must be referable", idxcnt + 1 + argoffset);
3408 continue;
3409 }
3410 if (have_range)
3411 {
3412 tree forxx, ptr, len, nametable, lower, upper;
3413
3414 forxx = build_component_ref (t, get_identifier ("__locsetrange"));
3415 ptr = build_component_ref (forxx, get_identifier ("ptr"));
3416 len = build_component_ref (forxx, get_identifier ("length"));
3417 nametable = build_component_ref (forxx, get_identifier ("name_table"));
3418 lower = build_component_ref (forxx, get_identifier ("lower"));
3419 upper = build_component_ref (forxx, get_identifier ("upper"));
3420 expand_assignment (ptr, item_addr, 0, 0);
3421 expand_assignment (len, size_in_bytes (item_type), 0, 0);
3422 expand_assignment (nametable, table_name, 0, 0);
3423 expand_assignment (lower, range_low, 0, 0);
3424 expand_assignment (upper, range_high, 0, 0);
3425
3426 enumname = "__IO_SetRangeLoc";
3427 }
3428 else
3429 {
3430 tree forxx, ptr, len, nametable;
3431
3432 forxx = build_component_ref (t, get_identifier ("__locset"));
3433 ptr = build_component_ref (forxx, get_identifier ("ptr"));
3434 len = build_component_ref (forxx, get_identifier ("length"));
3435 nametable = build_component_ref (forxx, get_identifier ("name_table"));
3436 expand_assignment (ptr, item_addr, 0, 0);
3437 expand_assignment (len, size_in_bytes (item_type), 0, 0);
3438 expand_assignment (nametable, table_name, 0, 0);
3439
3440 enumname = "__IO_SetLoc";
3441 }
3442 }
3443 else
3444 {
3445 tree forxx, value, nametable;
3446
3447 forxx = build_component_ref (t, get_identifier ("__valset"));
3448 value = build_component_ref (forxx, get_identifier ("value"));
3449 nametable = build_component_ref (forxx, get_identifier ("name_table"));
3450 expand_assignment (value, item, 0, 0);
3451 expand_assignment (nametable, table_name, 0, 0);
3452
3453 enumname = "__IO_SetVal";
3454 }
3455 }
3456 else if (chill_varying_string_type_p (item_type))
3457 {
3458 /* varying char string */
3459 tree t = build_component_ref (array_ref, get_identifier ("__t"));
3460 tree forxx = build_component_ref (t, get_identifier ("__loccharstring"));
3461 tree string = build_component_ref (forxx, get_identifier ("string"));
3462 tree length = build_component_ref (forxx, get_identifier ("string_length"));
3463
3464 if (do_read && readonly)
3465 {
3466 error ("argument %d is READonly", idxcnt + 1 + argoffset);
3467 continue;
3468 }
3469 if (do_read)
3470 {
3471 /* in this read case the argument must be referable */
3472 if (! referable)
3473 {
3474 error ("argument %d must be referable", idxcnt + 1 + argoffset);
3475 continue;
3476 }
3477 }
3478 else if (! referable)
3479 {
3480 /* in the write case we create a temporary if not referable */
3481 rtx t;
3482 tree loc = build_decl (VAR_DECL,
3483 get_unique_identifier ("WRTEXTVS"),
3484 item_type);
3485 t = assign_temp (item_type, 0, 1, 0);
3486 DECL_RTL (loc) = t;
3487 expand_assignment (loc, item, 0, 0);
3488 item_addr = force_addr_of (loc);
3489 item = loc;
3490 }
3491
3492 expand_assignment (string, item_addr, 0, 0);
3493 if (do_read)
3494 /* we must pass the maximum length of the varying */
3495 expand_assignment (length,
3496 size_in_bytes (TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (item_type)))),
3497 0, 0);
3498 else
3499 /* we pass the actual length of the string */
3500 expand_assignment (length,
3501 build_component_ref (item, var_length_id),
3502 0, 0);
3503
3504 enumname = "__IO_CharVaryingLoc";
3505 }
3506 else if (CH_CHARS_TYPE_P (item_type))
3507 {
3508 /* fixed character string */
3509 tree the_size;
3510 tree t = build_component_ref (array_ref, get_identifier ("__t"));
3511 tree forxx = build_component_ref (t, get_identifier ("__loccharstring"));
3512 tree string = build_component_ref (forxx, get_identifier ("string"));
3513 tree length = build_component_ref (forxx, get_identifier ("string_length"));
3514
3515 if (do_read && readonly)
3516 {
3517 error ("argument %d is READonly", idxcnt + 1 + argoffset);
3518 continue;
3519 }
3520 if (do_read)
3521 {
3522 /* in this read case the argument must be referable */
3523 if (! CH_REFERABLE (item))
3524 {
3525 error ("argument %d must be referable", idxcnt + 1 + argoffset);
3526 continue;
3527 }
3528 else
3529 item_addr = force_addr_of (item);
3530 the_size = size_in_bytes (item_type);
3531 enumname = "__IO_CharStrLoc";
3532 }
3533 else
3534 {
3535 if (! CH_REFERABLE (item))
3536 {
3537 /* in the write case we create a temporary if not referable */
3538 rtx t;
3539 int howmuchbytes;
3540
3541 howmuchbytes = int_size_in_bytes (item_type);
3542 if (howmuchbytes != -1)
3543 {
3544 /* fixed size */
3545 tree loc = build_decl (VAR_DECL,
3546 get_unique_identifier ("WRTEXTVS"),
3547 item_type);
3548 t = assign_temp (item_type, 0, 1, 0);
3549 DECL_RTL (loc) = t;
3550 expand_assignment (loc, item, 0, 0);
3551 item_addr = force_addr_of (loc);
3552 the_size = size_in_bytes (item_type);
3553 enumname = "__IO_CharStrLoc";
3554 }
3555 else
3556 {
3557 tree type, string, exp, loc;
3558
3559 if ((howmuchbytes = intsize_of_charsexpr (item)) == -1)
3560 {
3561 error ("cannot process argument %d of WRITETEXT, unknown size",
3562 idxcnt + 1 + argoffset);
3563 continue;
3564 }
3565 string = build_string_type (char_type_node,
3566 build_int_2 (howmuchbytes, 0));
3567 type = build_varying_struct (string);
3568 loc = build_decl (VAR_DECL,
3569 get_unique_identifier ("WRTEXTCS"),
3570 type);
3571 t = assign_temp (type, 0, 1, 0);
3572 DECL_RTL (loc) = t;
3573 exp = chill_convert_for_assignment (type, item, 0);
3574 expand_assignment (loc, exp, 0, 0);
3575 item_addr = force_addr_of (loc);
3576 the_size = integer_zero_node;
3577 enumname = "__IO_CharVaryingLoc";
3578 }
3579 }
3580 else
3581 {
3582 item_addr = force_addr_of (item);
3583 the_size = size_in_bytes (item_type);
3584 enumname = "__IO_CharStrLoc";
3585 }
3586 }
3587
3588 expand_assignment (string, item_addr, 0, 0);
3589 expand_assignment (length, size_in_bytes (item_type), 0, 0);
3590
3591 }
3592 else if (CH_BOOLS_TYPE_P (item_type))
3593 {
3594 /* we have a bitstring */
3595 tree t = build_component_ref (array_ref, get_identifier ("__t"));
3596 tree forxx = build_component_ref (t, get_identifier ("__loccharstring"));
3597 tree string = build_component_ref (forxx, get_identifier ("string"));
3598 tree length = build_component_ref (forxx, get_identifier ("string_length"));
3599
3600 if (do_read && readonly)
3601 {
3602 error ("argument %d is READonly", idxcnt + 1 + argoffset);
3603 continue;
3604 }
3605 if (do_read)
3606 {
3607 /* in this read case the argument must be referable */
3608 if (! referable)
3609 {
3610 error ("argument %d must be referable", idxcnt + 1 + argoffset);
3611 continue;
3612 }
3613 }
3614 else if (! referable)
3615 {
3616 /* in the write case we create a temporary if not referable */
3617 tree loc = build_decl (VAR_DECL,
3618 get_unique_identifier ("WRTEXTVS"),
3619 item_type);
3620 DECL_RTL (loc) = assign_temp (item_type, 0, 1, 0);
3621 expand_assignment (loc, item, 0, 0);
3622 item_addr = force_addr_of (loc);
3623 }
3624
3625 expand_assignment (string, item_addr, 0, 0);
3626 expand_assignment (length, build_chill_length (item), 0, 0);
3627
3628 enumname = "__IO_BitStrLoc";
3629 }
3630 else if (TREE_CODE (item_type) == REAL_TYPE)
3631 {
3632 /* process a (long_)real */
3633 tree t, forxx, to_assign;
3634
3635 if (do_read && readonly)
3636 {
3637 error ("argument %d is READonly", idxcnt + 1 + argoffset);
3638 continue;
3639 }
3640 if (do_read && ! referable)
3641 {
3642 error ("argument %d must be referable", idxcnt + 1 + argoffset);
3643 continue;
3644 }
3645
3646 if (lookup_name (ridpointers[RID_FLOAT]) == TYPE_NAME (item_type))
3647 {
3648 /* we have a real */
3649 if (do_read)
3650 {
3651 enumname = "__IO_RealLoc";
3652 fieldname = "__locreal";
3653 to_assign = item_addr;
3654 }
3655 else
3656 {
3657 enumname = "__IO_RealVal";
3658 fieldname = "__valreal";
3659 to_assign = item;
3660 }
3661 }
3662 else
3663 {
3664 /* we have a long_real */
3665 if (do_read)
3666 {
3667 enumname = "__IO_LongRealLoc";
3668 fieldname = "__loclongreal";
3669 to_assign = item_addr;
3670 }
3671 else
3672 {
3673 enumname = "__IO_LongRealVal";
3674 fieldname = "__vallongreal";
3675 to_assign = item;
3676 }
3677 }
3678 t = build_component_ref (array_ref, get_identifier ("__t"));
3679 forxx = build_component_ref (t, get_identifier (fieldname));
3680 expand_assignment (forxx, to_assign, 0, 0);
3681 }
3682 #if 0
3683 /* don't process them for now */
3684 else if (TREE_CODE (item_type) == POINTER_TYPE)
3685 {
3686 /* we have a pointer */
3687 tree __t, __forxx;
3688
3689 __t = build_component_ref (array_ref, get_identifier ("__t"));
3690 __forxx = build_component_ref (__t, get_identifier ("__forpointer"));
3691 expand_assignment (__forxx, item, 0, 0);
3692 enumname = "_IO_Pointer";
3693 }
3694 else if (item_type == instance_type_node)
3695 {
3696 /* we have an INSTANCE */
3697 tree __t, __forxx;
3698
3699 __t = build_component_ref (array_ref, get_identifier ("__t"));
3700 __forxx = build_component_ref (__t, get_identifier ("__forinstance"));
3701 expand_assignment (__forxx, item, 0, 0);
3702 enumname = "_IO_Instance";
3703 }
3704 #endif
3705 else
3706 {
3707 /* datatype is not yet implemented, issue a warning */
3708 error ("cannot process mode of argument %d for %sTEXT.", idxcnt + 1 + argoffset,
3709 do_read ? "READ" : "WRITE");
3710 enumname = "__IO_UNUSED";
3711 }
3712
3713 /* do assignment of the enum */
3714 if (enumname)
3715 {
3716 tree descr = build_component_ref (array_ref,
3717 get_identifier ("__descr"));
3718 expand_assignment (descr,
3719 lookup_name (get_identifier (enumname)), 0, 0);
3720 }
3721 }
3722
3723 /* set up address and length of iolist */
3724 *iolist_addr = build_chill_addr_expr (iolist, (char *)0);
3725 *iolist_length = build_int_2 (iolen, 0);
3726 }
3727 \f
3728 /* check the format string */
3729 #define LET 0x0001
3730 #define BIN 0x0002
3731 #define DEC 0x0004
3732 #define OCT 0x0008
3733 #define HEX 0x0010
3734 #define USC 0x0020
3735 #define BIL 0x0040
3736 #define SPC 0x0080
3737 #define SCS 0x0100
3738 #define IOC 0x0200
3739 #define EDC 0x0400
3740 #define CVC 0x0800
3741
3742 #define isDEC(c) ( chartab[(c)] & DEC )
3743 #define isCVC(c) ( chartab[(c)] & CVC )
3744 #define isEDC(c) ( chartab[(c)] & EDC )
3745 #define isIOC(c) ( chartab[(c)] & IOC )
3746 #define isUSC(c)
3747 #define isXXX(c,XXX) ( chartab[(c)] & XXX )
3748
3749 static
3750 short int chartab[256] = {
3751 0, 0, 0, 0, 0, 0, 0, 0,
3752 0, SPC, SPC, SPC, SPC, SPC, 0, 0,
3753
3754 0, 0, 0, 0, 0, 0, 0, 0,
3755 0, 0, 0, 0, 0, 0, 0, 0,
3756
3757 SPC, IOC, 0, 0, 0, 0, 0, 0,
3758 SCS, SCS, SCS, SCS+IOC, SCS, SCS+IOC, SCS, SCS+IOC,
3759 BIN+OCT+DEC+HEX, BIN+OCT+DEC+HEX, OCT+DEC+HEX, OCT+DEC+HEX, OCT+DEC+HEX,
3760 OCT+DEC+HEX, OCT+DEC+HEX, OCT+DEC+HEX,
3761 DEC+HEX, DEC+HEX, SCS, SCS, SCS+EDC, SCS+IOC, SCS+EDC, IOC,
3762
3763 0, LET+HEX+BIL, LET+HEX+BIL+CVC, LET+HEX+BIL+CVC, LET+HEX+BIL, LET+HEX,
3764 LET+HEX+CVC, LET,
3765 LET+BIL+CVC, LET, LET, LET, LET, LET, LET, LET+CVC,
3766
3767 LET, LET, LET, LET, LET+EDC, LET, LET, LET,
3768 LET+EDC, LET, LET, SCS, 0, SCS, 0, USC,
3769
3770 0, LET+HEX, LET+HEX, LET+HEX, LET+HEX, LET+HEX, LET+HEX, LET,
3771 LET, LET, LET, LET, LET, LET, LET, LET,
3772
3773 LET, LET, LET, LET, LET, LET, LET, LET,
3774 LET, LET, LET, 0, 0, 0, 0, 0
3775 };
3776
3777 typedef enum
3778 {
3779 FormatText, FirstPercent, RepFact, ConvClause, EditClause, ClauseEnd,
3780 AfterWidth, FractWidth, FractWidthCont, ExpoWidth, ExpoWidthCont,
3781 ClauseWidth, CatchPadding, LastPercent
3782 } fcsstate_t;
3783
3784 #define CONVERSIONCODES "CHOBF"
3785 typedef enum
3786 {
3787 DefaultConv, HexConv, OctalConv, BinaryConv, ScientConv
3788 } convcode_t;
3789 static convcode_t convcode;
3790
3791 typedef enum
3792 {
3793 False, True,
3794 } Boolean;
3795
3796 static unsigned long fractionwidth;
3797
3798 #define IOCODES "/+-?!="
3799 typedef enum {
3800 NextRecord, NextPage, CurrentLine, Prompt, Emit, EndPage
3801 } iocode_t;
3802 static iocode_t iocode;
3803
3804 #define EDITCODES "X<>T"
3805 typedef enum {
3806 SpaceSkip, SkipLeft, SkipRight, Tabulation
3807 } editcode_t;
3808 static editcode_t editcode;
3809
3810 static unsigned long clausewidth;
3811 static Boolean leftadjust;
3812 static Boolean overflowev;
3813 static Boolean dynamicwid;
3814 static Boolean paddingdef;
3815 static char paddingchar;
3816 static Boolean fractiondef;
3817 static Boolean exponentdef;
3818 static unsigned long exponentwidth;
3819 static unsigned long repetition;
3820
3821 typedef enum {
3822 NormalEnd, EndAtParen, TextFailEnd
3823 } formatexit_t;
3824
3825 /* NOTE: varibale have to be set to False before calling check_format_string */
3826 static Boolean empty_printed;
3827
3828 static int formstroffset;
3829
3830 static tree
3831 check_exprlist (code, exprlist, argnum, repetition)
3832 convcode_t code;
3833 tree exprlist;
3834 int argnum;
3835 unsigned long repetition;
3836 {
3837 tree expr, type, result = NULL_TREE;
3838
3839 while (repetition--)
3840 {
3841 if (exprlist == NULL_TREE)
3842 {
3843 if (empty_printed == False)
3844 {
3845 warning ("too few arguments for this format string");
3846 empty_printed = True;
3847 }
3848 return NULL_TREE;
3849 }
3850 expr = TREE_VALUE (exprlist);
3851 result = exprlist = TREE_CHAIN (exprlist);
3852 if (expr == NULL_TREE || TREE_CODE (expr) == ERROR_MARK)
3853 return result;
3854 type = TREE_TYPE (expr);
3855 if (type == NULL_TREE || TREE_CODE (type) == ERROR_MARK)
3856 return result;
3857 if (TREE_CODE (type) == REFERENCE_TYPE)
3858 type = TREE_TYPE (type);
3859 if (type == NULL_TREE || TREE_CODE (type) == ERROR_MARK)
3860 return result;
3861
3862 switch (code)
3863 {
3864 case DefaultConv:
3865 /* %C, everything is allowed. Not know types are flaged later. */
3866 break;
3867 case ScientConv:
3868 /* %F, must be a REAL */
3869 if (TREE_CODE (type) != REAL_TYPE)
3870 warning ("type of argument %d invalid for conversion code at offset %d",
3871 argnum, formstroffset);
3872 break;
3873 case HexConv:
3874 case OctalConv:
3875 case BinaryConv:
3876 case -1:
3877 /* %H, %O, %B, and V as clause width */
3878 if (TREE_CODE (type) != INTEGER_TYPE)
3879 warning ("type of argument %d invalid for conversion code at offset %d",
3880 argnum, formstroffset);
3881 break;
3882 default:
3883 /* there is an invalid conversion code */
3884 break;
3885 }
3886 }
3887 return result;
3888 }
3889
3890 static formatexit_t
3891 scanformcont (fcs, len, fcsptr, lenptr, exprlist, exprptr,
3892 firstargnum, nextargnum)
3893 char *fcs;
3894 int len;
3895 char **fcsptr;
3896 int *lenptr;
3897 tree exprlist;
3898 tree *exprptr;
3899 int firstargnum;
3900 int *nextargnum;
3901 {
3902 fcsstate_t state = FormatText;
3903 unsigned char curr;
3904 int dig;
3905
3906 while (len--)
3907 {
3908 curr = *fcs++;
3909 formstroffset++;
3910 switch (state)
3911 {
3912 case FormatText:
3913 if (curr == '%')
3914 state = FirstPercent;
3915 break;
3916
3917 after_first_percent: ;
3918 case FirstPercent:
3919 if (curr == '%')
3920 {
3921 state = FormatText;
3922 break;
3923 }
3924 if (curr == ')')
3925 {
3926 *lenptr = len;
3927 *fcsptr = fcs;
3928 *exprptr = exprlist;
3929 *nextargnum = firstargnum;
3930 return EndAtParen;
3931 }
3932 if (isDEC (curr))
3933 {
3934 state = RepFact;
3935 repetition = curr - '0';
3936 break;
3937 }
3938
3939 repetition = 1;
3940
3941 test_for_control_codes: ;
3942 if (isCVC (curr))
3943 {
3944 state = ConvClause;
3945 convcode = strchr (CONVERSIONCODES, curr) - CONVERSIONCODES;
3946 leftadjust = False;
3947 overflowev = False;
3948 dynamicwid = False;
3949 paddingdef = False;
3950 paddingchar = ' ';
3951 fractiondef = False;
3952 /* fractionwidth = 0; default depends on mode ! */
3953 exponentdef = False;
3954 exponentwidth = 3;
3955 clausewidth = 0;
3956 /* check the argument */
3957 exprlist = check_exprlist (convcode, exprlist, firstargnum, repetition);
3958 firstargnum++;
3959 break;
3960 }
3961 if (isEDC (curr))
3962 {
3963 state = EditClause;
3964 editcode = strchr (EDITCODES, curr) - EDITCODES;
3965 dynamicwid = False;
3966 clausewidth = editcode == Tabulation ? 0 : 1;
3967 break;
3968 }
3969 if (isIOC (curr))
3970 {
3971 state = ClauseEnd;
3972 iocode = strchr (IOCODES, curr) - IOCODES;
3973 break;
3974 }
3975 if (curr == '(')
3976 {
3977 unsigned long times = repetition;
3978 int cntlen;
3979 char* cntfcs;
3980 tree cntexprlist;
3981 int nextarg;
3982
3983 while (times--)
3984 {
3985 if (scanformcont (fcs, len, &cntfcs, &cntlen,
3986 exprlist, &cntexprlist,
3987 firstargnum, &nextarg) != EndAtParen )
3988 {
3989 warning ("unmatched open paren");
3990 break;
3991 }
3992 exprlist = cntexprlist;
3993 }
3994 fcs = cntfcs;
3995 len = cntlen;
3996 if (len < 0)
3997 len = 0;
3998 exprlist = cntexprlist;
3999 firstargnum = nextarg;
4000 state = FormatText;
4001 break;
4002 }
4003 warning ("bad format specification character (offset %d)", formstroffset);
4004 state = FormatText;
4005 /* skip one argument */
4006 if (exprlist != NULL_TREE)
4007 exprlist = TREE_CHAIN (exprlist);
4008 break;
4009
4010 case RepFact:
4011 if (isDEC (curr))
4012 {
4013 dig = curr - '0';
4014 if (repetition > (ULONG_MAX - dig)/10)
4015 {
4016 warning ("repetition factor overflow (offset %d)", formstroffset);
4017 return TextFailEnd;
4018 }
4019 repetition = repetition*10 + dig;
4020 break;
4021 }
4022 goto test_for_control_codes;
4023
4024 case ConvClause:
4025 if (isDEC (curr))
4026 {
4027 state = ClauseWidth;
4028 clausewidth = curr - '0';
4029 break;
4030 }
4031 if (curr == 'L')
4032 {
4033 if (leftadjust)
4034 warning ("duplicate qualifier (offset %d)", formstroffset);
4035 leftadjust = True;
4036 break;
4037 }
4038 if (curr == 'E')
4039 {
4040 if (overflowev)
4041 warning ("duplicate qualifier (offset %d)", formstroffset);
4042 overflowev = True;
4043 break;
4044 }
4045 if (curr == 'P')
4046 {
4047 if (paddingdef)
4048 warning ("duplicate qualifier (offset %d)", formstroffset);
4049 paddingdef = True;
4050 state = CatchPadding;
4051 break;
4052 }
4053
4054 test_for_variable_width: ;
4055 if (curr == 'V')
4056 {
4057 dynamicwid = True;
4058 state = AfterWidth;
4059 exprlist = check_exprlist (-1, exprlist, firstargnum, 1);
4060 firstargnum++;
4061 break;
4062 }
4063 goto test_for_fraction_width;
4064
4065 case ClauseWidth:
4066 if (isDEC (curr))
4067 {
4068 dig = curr - '0';
4069 if (clausewidth > (ULONG_MAX - dig)/10)
4070 warning ("clause width overflow (offset %d)", formstroffset);
4071 else
4072 clausewidth = clausewidth*10 + dig;
4073 break;
4074 }
4075 /* fall through */
4076
4077 test_for_fraction_width: ;
4078 case AfterWidth:
4079 if (curr == '.')
4080 {
4081 if (convcode != DefaultConv && convcode != ScientConv)
4082 {
4083 warning ("no fraction (offset %d)", formstroffset);
4084 state = FormatText;
4085 break;
4086 }
4087 fractiondef = True;
4088 state = FractWidth;
4089 break;
4090 }
4091 goto test_for_exponent_width;
4092
4093 case FractWidth:
4094 if (isDEC (curr))
4095 {
4096 state = FractWidthCont;
4097 fractionwidth = curr - '0';
4098 break;
4099 }
4100 else
4101 warning ("no fraction width (offset %d)", formstroffset);
4102
4103 case FractWidthCont:
4104 if (isDEC (curr))
4105 {
4106 dig = curr - '0';
4107 if (fractionwidth > (ULONG_MAX - dig)/10)
4108 warning ("fraction width overflow (offset %d)", formstroffset);
4109 else
4110 fractionwidth = fractionwidth*10 + dig;
4111 break;
4112 }
4113
4114 test_for_exponent_width: ;
4115 if (curr == ':')
4116 {
4117 if (convcode != ScientConv)
4118 {
4119 warning ("no exponent (offset %d)", formstroffset);
4120 state = FormatText;
4121 break;
4122 }
4123 exponentdef = True;
4124 state = ExpoWidth;
4125 break;
4126 }
4127 goto test_for_final_percent;
4128
4129 case ExpoWidth:
4130 if (isDEC (curr))
4131 {
4132 state = ExpoWidthCont;
4133 exponentwidth = curr - '0';
4134 break;
4135 }
4136 else
4137 warning ("no exponent width (offset %d)", formstroffset);
4138
4139 case ExpoWidthCont:
4140 if (isDEC (curr))
4141 {
4142 dig = curr - '0';
4143 if (exponentwidth > (ULONG_MAX - dig)/10)
4144 warning ("exponent width overflow (offset %d)", formstroffset);
4145 else
4146 exponentwidth = exponentwidth*10 + dig;
4147 break;
4148 }
4149 /* fall through */
4150
4151 test_for_final_percent: ;
4152 case ClauseEnd:
4153 if (curr == '%')
4154 {
4155 state = LastPercent;
4156 break;
4157 }
4158
4159 state = FormatText;
4160 break;
4161
4162 case CatchPadding:
4163 paddingchar = curr;
4164 state = ConvClause;
4165 break;
4166
4167 case EditClause:
4168 if (isDEC (curr))
4169 {
4170 state = ClauseWidth;
4171 clausewidth = curr - '0';
4172 break;
4173 }
4174 goto test_for_variable_width;
4175
4176 case LastPercent:
4177 if (curr == '.')
4178 {
4179 state = FormatText;
4180 break;
4181 }
4182 goto after_first_percent;
4183
4184 default:
4185 error ("internal error in check_format_string");
4186 }
4187 }
4188
4189 switch (state)
4190 {
4191 case FormatText:
4192 break;
4193 case FirstPercent:
4194 case LastPercent:
4195 case RepFact:
4196 case FractWidth:
4197 case ExpoWidth:
4198 warning ("bad format specification character (offset %d)", formstroffset);
4199 break;
4200 case CatchPadding:
4201 warning ("no padding character (offset %d)", formstroffset);
4202 break;
4203 default:
4204 break;
4205 }
4206 *fcsptr = fcs;
4207 *lenptr = len;
4208 *exprptr = exprlist;
4209 *nextargnum = firstargnum;
4210 return NormalEnd;
4211 }
4212 static void
4213 check_format_string (format_str, exprlist, firstargnum)
4214 tree format_str;
4215 tree exprlist;
4216 int firstargnum;
4217 {
4218 char *x;
4219 int y, yy;
4220 tree z = NULL_TREE;
4221
4222 if (TREE_CODE (format_str) != STRING_CST)
4223 /* do nothing if we don't have a string constant */
4224 return;
4225
4226 formstroffset = -1;
4227 scanformcont (TREE_STRING_POINTER (format_str),
4228 TREE_STRING_LENGTH (format_str), &x, &y,
4229 exprlist, &z,
4230 firstargnum, &yy);
4231 if (z != NULL_TREE)
4232 /* too may arguments for format string */
4233 warning ("too many arguments for this format string");
4234 }
4235 \f
4236 static int
4237 get_max_size (expr)
4238 tree expr;
4239 {
4240 if (TREE_CODE (expr) == INDIRECT_REF)
4241 {
4242 tree x = TREE_OPERAND (expr, 0);
4243 tree y = TREE_OPERAND (x, 0);
4244 return int_size_in_bytes (TREE_TYPE (y));
4245 }
4246 else if (TREE_CODE (expr) == CONCAT_EXPR)
4247 return intsize_of_charsexpr (expr);
4248 else
4249 return int_size_in_bytes (TREE_TYPE (expr));
4250 }
4251
4252 static int
4253 intsize_of_charsexpr (expr)
4254 tree expr;
4255 {
4256 int op0size, op1size;
4257
4258 if (TREE_CODE (expr) != CONCAT_EXPR)
4259 return -1;
4260
4261 /* find maximum length of CONCAT_EXPR, this is the worst case */
4262 op0size = get_max_size (TREE_OPERAND (expr, 0));
4263 op1size = get_max_size (TREE_OPERAND (expr, 1));
4264 if (op0size == -1 || op1size == -1)
4265 return -1;
4266 return op0size + op1size;
4267 }
4268
4269 tree
4270 build_chill_writetext (text_arg, exprlist)
4271 tree text_arg, exprlist;
4272 {
4273 tree iolist_addr = null_pointer_node;
4274 tree iolist_length = integer_zero_node;
4275 tree fstr_addr;
4276 tree fstr_length;
4277 tree outstr_addr;
4278 tree outstr_length;
4279 tree fstrtype;
4280 tree outfunction;
4281 tree filename, linenumber;
4282 tree format_str = NULL_TREE, indexexpr = NULL_TREE;
4283 rtx iolist_rtx = NULL_RTX;
4284 int argoffset = 0;
4285
4286 /* make some checks */
4287 if (text_arg == NULL_TREE || TREE_CODE (text_arg) == ERROR_MARK)
4288 return error_mark_node;
4289
4290 if (exprlist != NULL_TREE)
4291 {
4292 if (TREE_CODE (exprlist) != TREE_LIST)
4293 return error_mark_node;
4294 }
4295
4296 /* check the text argument */
4297 if (chill_varying_string_type_p (TREE_TYPE (text_arg)))
4298 {
4299 /* build outstr-addr and outstr-length assuming that this is a CHAR (n) VARYING */
4300 outstr_addr = force_addr_of (text_arg);
4301 outstr_length = size_in_bytes (CH_VARYING_ARRAY_TYPE (TREE_TYPE (text_arg)));
4302 outfunction = lookup_name (get_identifier ("__writetext_s"));
4303 format_str = TREE_VALUE (exprlist);
4304 exprlist = TREE_CHAIN (exprlist);
4305 }
4306 else if (CH_IS_TEXT_MODE (TREE_TYPE (text_arg)))
4307 {
4308 /* we have a text mode */
4309 tree indexmode;
4310
4311 if (! check_text (text_arg, 1, "WRITETEXT"))
4312 return error_mark_node;
4313 indexmode = text_indexmode (TREE_TYPE (text_arg));
4314 if (indexmode == void_type_node)
4315 {
4316 /* no index */
4317 format_str = TREE_VALUE (exprlist);
4318 exprlist = TREE_CHAIN (exprlist);
4319 }
4320 else
4321 {
4322 /* we have an index. there must be an index argument before format string */
4323 indexexpr = TREE_VALUE (exprlist);
4324 exprlist = TREE_CHAIN (exprlist);
4325 if (! CH_COMPATIBLE (indexexpr, indexmode))
4326 {
4327 if (chill_varying_string_type_p (TREE_TYPE (indexexpr)) ||
4328 (CH_CHARS_TYPE_P (TREE_TYPE (indexexpr)) ||
4329 (flag_old_strings && TREE_CODE (indexexpr) == INTEGER_CST &&
4330 TREE_CODE (TREE_TYPE (indexexpr)) == CHAR_TYPE)))
4331 error ("missing index expression");
4332 else
4333 error ("incompatible index mode");
4334 return error_mark_node;
4335 }
4336 if (exprlist == NULL_TREE)
4337 {
4338 error ("Too few arguments in call to `writetext'");
4339 return error_mark_node;
4340 }
4341 format_str = TREE_VALUE (exprlist);
4342 exprlist = TREE_CHAIN (exprlist);
4343 argoffset = 1;
4344 }
4345 outstr_addr = force_addr_of (text_arg);
4346 outstr_length = convert (integer_type_node, indexexpr);
4347 outfunction = lookup_name (get_identifier ("__writetext_f"));
4348 }
4349 else
4350 {
4351 error ("argument 1 for WRITETEXT must be a TEXT or CHARS(n) VARYING location");
4352 return error_mark_node;
4353 }
4354
4355 /* check the format string */
4356 fstrtype = TREE_TYPE (format_str);
4357 if (CH_CHARS_TYPE_P (fstrtype) ||
4358 (flag_old_strings && TREE_CODE (format_str) == INTEGER_CST &&
4359 TREE_CODE (fstrtype) == CHAR_TYPE))
4360 {
4361 /* we have a character string */
4362 fstr_addr = force_addr_of (format_str);
4363 fstr_length = size_in_bytes (fstrtype);
4364 }
4365 else if (chill_varying_string_type_p (TREE_TYPE (format_str)))
4366 {
4367 /* we have a varying char string */
4368 fstr_addr
4369 = force_addr_of (build_component_ref (format_str, var_data_id));
4370 fstr_length = build_component_ref (format_str, var_length_id);
4371 }
4372 else
4373 {
4374 error ("`format string' for WRITETEXT must be a CHARACTER string");
4375 return error_mark_node;
4376 }
4377
4378 empty_printed = False;
4379 check_format_string (format_str, exprlist, argoffset + 3);
4380 process_io_list (exprlist, &iolist_addr, &iolist_length, &iolist_rtx, 0, argoffset);
4381
4382 /* tree to call the function */
4383
4384 filename = force_addr_of (get_chill_filename ());
4385 linenumber = get_chill_linenumber ();
4386
4387 expand_expr_stmt (
4388 build_chill_function_call (outfunction,
4389 tree_cons (NULL_TREE, outstr_addr,
4390 tree_cons (NULL_TREE, outstr_length,
4391 tree_cons (NULL_TREE, fstr_addr,
4392 tree_cons (NULL_TREE, fstr_length,
4393 tree_cons (NULL_TREE, iolist_addr,
4394 tree_cons (NULL_TREE, iolist_length,
4395 tree_cons (NULL_TREE, filename,
4396 tree_cons (NULL_TREE, linenumber,
4397 NULL_TREE))))))))));
4398
4399 /* get rid of the iolist variable, if we have one */
4400 if (iolist_rtx != NULL_RTX)
4401 {
4402 free_temp_slots ();
4403 pop_temp_slots ();
4404 free_temp_slots ();
4405 pop_temp_slots ();
4406 }
4407
4408 /* return something the rest of the machinery can work with,
4409 i.e. (void)0 */
4410 return build1 (CONVERT_EXPR, void_type_node, integer_zero_node);
4411 }
4412
4413 tree
4414 build_chill_readtext (text_arg, exprlist)
4415 tree text_arg, exprlist;
4416 {
4417 tree instr_addr, instr_length, infunction;
4418 tree fstr_addr, fstr_length, fstrtype;
4419 tree iolist_addr = null_pointer_node;
4420 tree iolist_length = integer_zero_node;
4421 tree filename, linenumber;
4422 tree format_str = NULL_TREE, indexexpr = NULL_TREE;
4423 rtx iolist_rtx = NULL_RTX;
4424 int argoffset = 0;
4425
4426 /* make some checks */
4427 if (text_arg == NULL_TREE || TREE_CODE (text_arg) == ERROR_MARK)
4428 return error_mark_node;
4429
4430 if (exprlist != NULL_TREE)
4431 {
4432 if (TREE_CODE (exprlist) != TREE_LIST)
4433 return error_mark_node;
4434 }
4435
4436 /* check the text argument */
4437 if (CH_CHARS_TYPE_P (TREE_TYPE (text_arg)))
4438 {
4439 instr_addr = force_addr_of (text_arg);
4440 instr_length = size_in_bytes (TREE_TYPE (text_arg));
4441 infunction = lookup_name (get_identifier ("__readtext_s"));
4442 format_str = TREE_VALUE (exprlist);
4443 exprlist = TREE_CHAIN (exprlist);
4444 }
4445 else if (chill_varying_string_type_p (TREE_TYPE (text_arg)))
4446 {
4447 instr_addr
4448 = force_addr_of (build_component_ref (text_arg, var_data_id));
4449 instr_length = build_component_ref (text_arg, var_length_id);
4450 infunction = lookup_name (get_identifier ("__readtext_s"));
4451 format_str = TREE_VALUE (exprlist);
4452 exprlist = TREE_CHAIN (exprlist);
4453 }
4454 else if (CH_IS_TEXT_MODE (TREE_TYPE (text_arg)))
4455 {
4456 /* we have a text mode */
4457 tree indexmode;
4458
4459 if (! check_text (text_arg, 1, "READTEXT"))
4460 return error_mark_node;
4461 indexmode = text_indexmode (TREE_TYPE (text_arg));
4462 if (indexmode == void_type_node)
4463 {
4464 /* no index */
4465 format_str = TREE_VALUE (exprlist);
4466 exprlist = TREE_CHAIN (exprlist);
4467 }
4468 else
4469 {
4470 /* we have an index. there must be an index argument before format string */
4471 indexexpr = TREE_VALUE (exprlist);
4472 exprlist = TREE_CHAIN (exprlist);
4473 if (! CH_COMPATIBLE (indexexpr, indexmode))
4474 {
4475 if (chill_varying_string_type_p (TREE_TYPE (indexexpr)) ||
4476 (CH_CHARS_TYPE_P (TREE_TYPE (indexexpr)) ||
4477 (flag_old_strings && TREE_CODE (indexexpr) == INTEGER_CST &&
4478 TREE_CODE (TREE_TYPE (indexexpr)) == CHAR_TYPE)))
4479 error ("missing index expression");
4480 else
4481 error ("incompatible index mode");
4482 return error_mark_node;
4483 }
4484 if (exprlist == NULL_TREE)
4485 {
4486 error ("Too few arguments in call to `readtext'");
4487 return error_mark_node;
4488 }
4489 format_str = TREE_VALUE (exprlist);
4490 exprlist = TREE_CHAIN (exprlist);
4491 argoffset = 1;
4492 }
4493 instr_addr = force_addr_of (text_arg);
4494 instr_length = convert (integer_type_node, indexexpr);
4495 infunction = lookup_name (get_identifier ("__readtext_f"));
4496 }
4497 else
4498 {
4499 error ("argument 1 for READTEXT must be a TEXT location or CHARS(n) [ VARYING ] expression");
4500 return error_mark_node;
4501 }
4502
4503 /* check the format string */
4504 fstrtype = TREE_TYPE (format_str);
4505 if (CH_CHARS_TYPE_P (fstrtype))
4506 {
4507 /* we have a character string */
4508 fstr_addr = force_addr_of (format_str);
4509 fstr_length = size_in_bytes (fstrtype);
4510 }
4511 else if (chill_varying_string_type_p (fstrtype))
4512 {
4513 /* we have a CHARS(n) VARYING */
4514 fstr_addr
4515 = force_addr_of (build_component_ref (format_str, var_data_id));
4516 fstr_length = build_component_ref (format_str, var_length_id);
4517 }
4518 else
4519 {
4520 error ("`format string' for READTEXT must be a CHARACTER string");
4521 return error_mark_node;
4522 }
4523
4524 empty_printed = False;
4525 check_format_string (format_str, exprlist, argoffset + 3);
4526 process_io_list (exprlist, &iolist_addr, &iolist_length, &iolist_rtx, 1, argoffset);
4527
4528 /* build the function call */
4529 filename = force_addr_of (get_chill_filename ());
4530 linenumber = get_chill_linenumber ();
4531 expand_expr_stmt (
4532 build_chill_function_call (infunction,
4533 tree_cons (NULL_TREE, instr_addr,
4534 tree_cons (NULL_TREE, instr_length,
4535 tree_cons (NULL_TREE, fstr_addr,
4536 tree_cons (NULL_TREE, fstr_length,
4537 tree_cons (NULL_TREE, iolist_addr,
4538 tree_cons (NULL_TREE, iolist_length,
4539 tree_cons (NULL_TREE, filename,
4540 tree_cons (NULL_TREE, linenumber,
4541 NULL_TREE))))))))));
4542
4543 /* get rid of the iolist variable, if we have one */
4544 if (iolist_rtx != NULL_RTX)
4545 {
4546 free_temp_slots ();
4547 pop_temp_slots ();
4548 free_temp_slots ();
4549 pop_temp_slots ();
4550 }
4551
4552 /* return something the rest of the machinery can work with,
4553 i.e. (void)0 */
4554 return build1 (CONVERT_EXPR, void_type_node, integer_zero_node);
4555 }
4556
4557 /* this function build all neccesary enum-tables used for
4558 WRITETEXT or READTEXT of an enum */
4559
4560 void build_enum_tables ()
4561 {
4562 SAVE_ENUM_NAMES *names;
4563 SAVE_ENUMS *wrk;
4564 void *saveptr;
4565 /* We temporarily reset the maximum_field_alignment to zero so the
4566 compiler's init data structures can be compatible with the
4567 run-time system, even when we're compiling with -fpack. */
4568 extern int maximum_field_alignment;
4569 int save_maximum_field_alignment;
4570
4571 if (pass == 1)
4572 return;
4573
4574 save_maximum_field_alignment = maximum_field_alignment;
4575 maximum_field_alignment = 0;
4576
4577 /* output all names */
4578 names = used_enum_names;
4579
4580 while (names != (SAVE_ENUM_NAMES *)0)
4581 {
4582 tree var = get_unique_identifier ("ENUMNAME");
4583 tree type;
4584
4585 type = build_string_type (char_type_node,
4586 build_int_2 (IDENTIFIER_LENGTH (names->name) + 1, 0));
4587 names->decl = decl_temp1 (var, type, 1,
4588 build_chill_string (IDENTIFIER_LENGTH (names->name) + 1,
4589 IDENTIFIER_POINTER (names->name)),
4590 0, 0);
4591 names = names->forward;
4592 }
4593
4594 /* output the tables and pointers to tables */
4595 wrk = used_enums;
4596 while (wrk != (SAVE_ENUMS *)0)
4597 {
4598 tree varptr = wrk->ptrdecl;
4599 tree table_addr = null_pointer_node;
4600 tree init = NULL_TREE, one_entry;
4601 tree table, idxlist, tabletype, addr;
4602 SAVE_ENUM_VALUES *vals;
4603 int i;
4604
4605 vals = wrk->vals;
4606 for (i = 0; i < wrk->num_vals; i++)
4607 {
4608 tree decl = vals->name->decl;
4609 addr = build1 (ADDR_EXPR,
4610 build_pointer_type (char_type_node),
4611 decl);
4612 TREE_CONSTANT (addr) = 1;
4613 one_entry = tree_cons (NULL_TREE, build_int_2 (vals->val, 0),
4614 tree_cons (NULL_TREE, addr, NULL_TREE));
4615 one_entry = build_nt (CONSTRUCTOR, NULL_TREE, one_entry);
4616 init = tree_cons (NULL_TREE, one_entry, init);
4617 vals++;
4618 }
4619
4620 /* add the terminator (name = null_pointer_node) to constructor */
4621 one_entry = tree_cons (NULL_TREE, integer_zero_node,
4622 tree_cons (NULL_TREE, null_pointer_node, NULL_TREE));
4623 one_entry = build_nt (CONSTRUCTOR, NULL_TREE, one_entry);
4624 init = tree_cons (NULL_TREE, one_entry, init);
4625 init = nreverse (init);
4626 init = build_nt (CONSTRUCTOR, NULL_TREE, init);
4627 TREE_CONSTANT (init) = 1;
4628
4629 /* generate table */
4630 idxlist = build_tree_list (NULL_TREE,
4631 build_chill_range_type (NULL_TREE,
4632 integer_zero_node,
4633 build_int_2 (wrk->num_vals, 0)));
4634 tabletype = build_chill_array_type (TREE_TYPE (enum_table_type),
4635 idxlist, 0, NULL_TREE);
4636 table = decl_temp1 (get_unique_identifier ("ENUMTAB"), tabletype,
4637 1, init, 0, 0);
4638 table_addr = build1 (ADDR_EXPR,
4639 build_pointer_type (TREE_TYPE (enum_table_type)),
4640 table);
4641 TREE_CONSTANT (table_addr) = 1;
4642
4643 /* generate pointer to table */
4644 decl_temp1 (DECL_NAME (varptr), TREE_TYPE (table_addr),
4645 1, table_addr, 0, 0);
4646
4647 /* free that stuff */
4648 saveptr = wrk->forward;
4649
4650 free (wrk->vals);
4651 free (wrk);
4652
4653 /* next enum */
4654 wrk = saveptr;
4655 }
4656
4657 /* free all the names */
4658 names = used_enum_names;
4659 while (names != (SAVE_ENUM_NAMES *)0)
4660 {
4661 saveptr = names->forward;
4662 free (names);
4663 names = saveptr;
4664 }
4665
4666 used_enums = (SAVE_ENUMS *)0;
4667 used_enum_names = (SAVE_ENUM_NAMES *)0;
4668 maximum_field_alignment = save_maximum_field_alignment;
4669 }
Mirror of the offical gcc git repository hosted at gcc.gnu.org