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