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