?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
2003-05-12 Janis Johnson <janis187@us.ibm.com>
[official-gcc.git] / gcc / f / ste.c
blobf27c93ec2969d983a1cac31d03c1290f3bcca32c
1 /* ste.c -- Implementation File (module.c template V1.0)
2 Copyright (C) 1995, 1996, 2000, 2002, 2003 Free Software Foundation, Inc.
3 Contributed by James Craig Burley.
4
5 This file is part of GNU Fortran.
6
7 GNU Fortran is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 2, or (at your option)
10 any later version.
11
12 GNU Fortran is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
16
17 You should have received a copy of the GNU General Public License
18 along with GNU Fortran; see the file COPYING. If not, write to
19 the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
20 02111-1307, USA.
21
22 Related Modules:
23 ste.c
24
25 Description:
26 Implements the various statements and such like.
27
28 Modifications:
29 */
30
31 /* Include files. */
32
33 #include "proj.h"
34 #include "rtl.h"
35 #include "toplev.h"
36 #include "ggc.h"
37 #include "ste.h"
38 #include "bld.h"
39 #include "com.h"
40 #include "expr.h"
41 #include "lab.h"
42 #include "lex.h"
43 #include "sta.h"
44 #include "stp.h"
45 #include "str.h"
46 #include "sts.h"
47 #include "stt.h"
48 #include "stv.h"
49 #include "stw.h"
50 #include "symbol.h"
51
52 /* Externals defined here. */
53
54
55 /* Simple definitions and enumerations. */
56
57 typedef enum
58 {
59 FFESTE_stateletSIMPLE_, /* Expecting simple/start. */
60 FFESTE_stateletATTRIB_, /* Expecting attrib/item/itemstart. */
61 FFESTE_stateletITEM_, /* Expecting item/itemstart/finish. */
62 FFESTE_stateletITEMVALS_, /* Expecting itemvalue/itemendvals. */
63 FFESTE_
64 } ffesteStatelet_;
65
66 /* Internal typedefs. */
67
68
69 /* Private include files. */
70
71
72 /* Internal structure definitions. */
73
74
75 /* Static objects accessed by functions in this module. */
76
77 static ffesteStatelet_ ffeste_statelet_ = FFESTE_stateletSIMPLE_;
78 static ffelab ffeste_label_formatdef_ = NULL;
79 static tree (*ffeste_io_driver_) (ffebld expr); /* do?io. */
80 static ffecomGfrt ffeste_io_endgfrt_; /* end function to call. */
81 static tree ffeste_io_abort_; /* abort-io label or NULL_TREE. */
82 static bool ffeste_io_abort_is_temp_; /* abort-io label is a temp. */
83 static tree ffeste_io_end_; /* END= label or NULL_TREE. */
84 static tree ffeste_io_err_; /* ERR= label or NULL_TREE. */
85 static tree ffeste_io_iostat_; /* IOSTAT= var or NULL_TREE. */
86 static bool ffeste_io_iostat_is_temp_; /* IOSTAT= var is a temp. */
87
88 /* Static functions (internal). */
89
90 static void ffeste_begin_iterdo_ (ffestw block, tree *tvar, tree *tincr,
91 tree *xitersvar, ffebld var,
92 ffebld start, ffelexToken start_token,
93 ffebld end, ffelexToken end_token,
94 ffebld incr, ffelexToken incr_token,
95 const char *msg);
96 static void ffeste_end_iterdo_ (ffestw block, tree tvar, tree tincr,
97 tree itersvar);
98 static void ffeste_io_call_ (tree call, bool do_check);
99 static void ffeste_io_impdo_ (ffebld impdo, ffelexToken impdo_token);
100 static tree ffeste_io_dofio_ (ffebld expr);
101 static tree ffeste_io_dolio_ (ffebld expr);
102 static tree ffeste_io_douio_ (ffebld expr);
103 static tree ffeste_io_ialist_ (bool have_err, ffestvUnit unit,
104 ffebld unit_expr, int unit_dflt);
105 static tree ffeste_io_cilist_ (bool have_err, ffestvUnit unit,
106 ffebld unit_expr, int unit_dflt,
107 bool have_end, ffestvFormat format,
108 ffestpFile *format_spec, bool rec,
109 ffebld rec_expr);
110 static tree ffeste_io_cllist_ (bool have_err, ffebld unit_expr,
111 ffestpFile *stat_spec);
112 static tree ffeste_io_icilist_ (bool have_err, ffebld unit_expr,
113 bool have_end, ffestvFormat format,
114 ffestpFile *format_spec);
115 static tree ffeste_io_inlist_ (bool have_err,
116 ffestpFile *unit_spec,
117 ffestpFile *file_spec,
118 ffestpFile *exist_spec,
119 ffestpFile *open_spec,
120 ffestpFile *number_spec,
121 ffestpFile *named_spec,
122 ffestpFile *name_spec,
123 ffestpFile *access_spec,
124 ffestpFile *sequential_spec,
125 ffestpFile *direct_spec,
126 ffestpFile *form_spec,
127 ffestpFile *formatted_spec,
128 ffestpFile *unformatted_spec,
129 ffestpFile *recl_spec,
130 ffestpFile *nextrec_spec,
131 ffestpFile *blank_spec);
132 static tree ffeste_io_olist_ (bool have_err, ffebld unit_expr,
133 ffestpFile *file_spec,
134 ffestpFile *stat_spec,
135 ffestpFile *access_spec,
136 ffestpFile *form_spec,
137 ffestpFile *recl_spec,
138 ffestpFile *blank_spec);
139 static void ffeste_subr_beru_ (ffestpBeruStmt *info, ffecomGfrt rt);
140
141 /* Internal macros. */
142
143 #define ffeste_emit_line_note_() \
144 emit_line_note (input_filename, input_line)
145 #define ffeste_check_simple_() \
146 assert(ffeste_statelet_ == FFESTE_stateletSIMPLE_)
147 #define ffeste_check_start_() \
148 assert(ffeste_statelet_ == FFESTE_stateletSIMPLE_); \
149 ffeste_statelet_ = FFESTE_stateletATTRIB_
150 #define ffeste_check_attrib_() \
151 assert(ffeste_statelet_ == FFESTE_stateletATTRIB_)
152 #define ffeste_check_item_() \
153 assert(ffeste_statelet_ == FFESTE_stateletATTRIB_ \
154 || ffeste_statelet_ == FFESTE_stateletITEM_); \
155 ffeste_statelet_ = FFESTE_stateletITEM_
156 #define ffeste_check_item_startvals_() \
157 assert(ffeste_statelet_ == FFESTE_stateletATTRIB_ \
158 || ffeste_statelet_ == FFESTE_stateletITEM_); \
159 ffeste_statelet_ = FFESTE_stateletITEMVALS_
160 #define ffeste_check_item_value_() \
161 assert(ffeste_statelet_ == FFESTE_stateletITEMVALS_)
162 #define ffeste_check_item_endvals_() \
163 assert(ffeste_statelet_ == FFESTE_stateletITEMVALS_); \
164 ffeste_statelet_ = FFESTE_stateletITEM_
165 #define ffeste_check_finish_() \
166 assert(ffeste_statelet_ == FFESTE_stateletATTRIB_ \
167 || ffeste_statelet_ == FFESTE_stateletITEM_); \
168 ffeste_statelet_ = FFESTE_stateletSIMPLE_
169
170 #define ffeste_f2c_init_charnolen_(Exp,Init,Spec) \
171 do \
172 { \
173 if ((Spec)->kw_or_val_present) \
174 Exp = ffecom_arg_ptr_to_const_expr ((Spec)->u.expr, &ignore); \
175 else \
176 Exp = null_pointer_node; \
177 if (Exp) \
178 Init = Exp; \
179 else \
180 { \
181 Init = null_pointer_node; \
182 constantp = FALSE; \
183 } \
184 } while(0)
185
186 #define ffeste_f2c_init_char_(Exp,Init,Lenexp,Leninit,Spec) \
187 do \
188 { \
189 if ((Spec)->kw_or_val_present) \
190 Exp = ffecom_arg_ptr_to_const_expr ((Spec)->u.expr, &Lenexp); \
191 else \
192 { \
193 Exp = null_pointer_node; \
194 Lenexp = ffecom_f2c_ftnlen_zero_node; \
195 } \
196 if (Exp) \
197 Init = Exp; \
198 else \
199 { \
200 Init = null_pointer_node; \
201 constantp = FALSE; \
202 } \
203 if (Lenexp) \
204 Leninit = Lenexp; \
205 else \
206 { \
207 Leninit = ffecom_f2c_ftnlen_zero_node; \
208 constantp = FALSE; \
209 } \
210 } while(0)
211
212 #define ffeste_f2c_init_flag_(Flag,Init) \
213 do \
214 { \
215 Init = convert (ffecom_f2c_flag_type_node, \
216 (Flag) ? integer_one_node : integer_zero_node); \
217 } while(0)
218
219 #define ffeste_f2c_init_format_(Exp,Init,Spec) \
220 do \
221 { \
222 Exp = ffecom_arg_ptr_to_const_expr ((Spec)->u.expr, NULL); \
223 if (Exp) \
224 Init = Exp; \
225 else \
226 { \
227 Init = null_pointer_node; \
228 constantp = FALSE; \
229 } \
230 } while(0)
231
232 #define ffeste_f2c_init_int_(Exp,Init,Spec) \
233 do \
234 { \
235 if ((Spec)->kw_or_val_present) \
236 Exp = ffecom_const_expr ((Spec)->u.expr); \
237 else \
238 Exp = ffecom_integer_zero_node; \
239 if (Exp) \
240 Init = Exp; \
241 else \
242 { \
243 Init = ffecom_integer_zero_node; \
244 constantp = FALSE; \
245 } \
246 } while(0)
247
248 #define ffeste_f2c_init_ptrtoint_(Exp,Init,Spec) \
249 do \
250 { \
251 if ((Spec)->kw_or_val_present) \
252 Exp = ffecom_ptr_to_const_expr ((Spec)->u.expr); \
253 else \
254 Exp = null_pointer_node; \
255 if (Exp) \
256 Init = Exp; \
257 else \
258 { \
259 Init = null_pointer_node; \
260 constantp = FALSE; \
261 } \
262 } while(0)
263
264 #define ffeste_f2c_init_next_(Init) \
265 do \
266 { \
267 TREE_CHAIN (initn) = build_tree_list ((field = TREE_CHAIN (field)), \
268 (Init)); \
269 initn = TREE_CHAIN(initn); \
270 } while(0)
271
272 #define ffeste_f2c_prepare_charnolen_(Spec,Exp) \
273 do \
274 { \
275 if (! (Exp)) \
276 ffecom_prepare_arg_ptr_to_expr ((Spec)->u.expr); \
277 } while(0)
278
279 #define ffeste_f2c_prepare_char_(Spec,Exp) \
280 do \
281 { \
282 if (! (Exp)) \
283 ffecom_prepare_arg_ptr_to_expr ((Spec)->u.expr); \
284 } while(0)
285
286 #define ffeste_f2c_prepare_format_(Spec,Exp) \
287 do \
288 { \
289 if (! (Exp)) \
290 ffecom_prepare_arg_ptr_to_expr ((Spec)->u.expr); \
291 } while(0)
292
293 #define ffeste_f2c_prepare_int_(Spec,Exp) \
294 do \
295 { \
296 if (! (Exp)) \
297 ffecom_prepare_expr ((Spec)->u.expr); \
298 } while(0)
299
300 #define ffeste_f2c_prepare_ptrtoint_(Spec,Exp) \
301 do \
302 { \
303 if (! (Exp)) \
304 ffecom_prepare_ptr_to_expr ((Spec)->u.expr); \
305 } while(0)
306
307 #define ffeste_f2c_compile_(Field,Exp) \
308 do \
309 { \
310 tree exz; \
311 if ((Exp)) \
312 { \
313 exz = ffecom_modify (void_type_node, \
314 ffecom_2 (COMPONENT_REF, TREE_TYPE (Field), \
315 t, (Field)), \
316 (Exp)); \
317 expand_expr_stmt (exz); \
318 } \
319 } while(0)
320
321 #define ffeste_f2c_compile_charnolen_(Field,Spec,Exp) \
322 do \
323 { \
324 tree exq; \
325 if (! (Exp)) \
326 { \
327 exq = ffecom_arg_ptr_to_expr ((Spec)->u.expr, &ignore); \
328 ffeste_f2c_compile_ ((Field), exq); \
329 } \
330 } while(0)
331
332 #define ffeste_f2c_compile_char_(Field,Lenfield,Spec,Exp,Lenexp) \
333 do \
334 { \
335 tree exq = (Exp); \
336 tree lenexq = (Lenexp); \
337 int need_exq = (! exq); \
338 int need_lenexq = (! lenexq); \
339 if (need_exq || need_lenexq) \
340 { \
341 exq = ffecom_arg_ptr_to_expr ((Spec)->u.expr, &lenexq); \
342 if (need_exq) \
343 ffeste_f2c_compile_ ((Field), exq); \
344 if (need_lenexq) \
345 ffeste_f2c_compile_ ((Lenfield), lenexq); \
346 } \
347 } while(0)
348
349 #define ffeste_f2c_compile_format_(Field,Spec,Exp) \
350 do \
351 { \
352 tree exq; \
353 if (! (Exp)) \
354 { \
355 exq = ffecom_arg_ptr_to_expr ((Spec)->u.expr, NULL); \
356 ffeste_f2c_compile_ ((Field), exq); \
357 } \
358 } while(0)
359
360 #define ffeste_f2c_compile_int_(Field,Spec,Exp) \
361 do \
362 { \
363 tree exq; \
364 if (! (Exp)) \
365 { \
366 exq = ffecom_expr ((Spec)->u.expr); \
367 ffeste_f2c_compile_ ((Field), exq); \
368 } \
369 } while(0)
370
371 #define ffeste_f2c_compile_ptrtoint_(Field,Spec,Exp) \
372 do \
373 { \
374 tree exq; \
375 if (! (Exp)) \
376 { \
377 exq = ffecom_ptr_to_expr ((Spec)->u.expr); \
378 ffeste_f2c_compile_ ((Field), exq); \
379 } \
380 } while(0)
381 \f
382 /* Start a Fortran block. */
383
384 #ifdef ENABLE_CHECKING
385
386 typedef struct gbe_block
387 {
388 struct gbe_block *outer;
389 ffestw block;
390 location_t location;
391 bool is_stmt;
392 } *gbe_block;
393
394 gbe_block ffeste_top_block_ = NULL;
395
396 static void
397 ffeste_start_block_ (ffestw block)
398 {
399 gbe_block b = xmalloc (sizeof (*b));
400
401 b->outer = ffeste_top_block_;
402 b->block = block;
403 b->location = input_location;
404 b->is_stmt = FALSE;
405
406 ffeste_top_block_ = b;
407
408 ffecom_start_compstmt ();
409 }
410
411 /* End a Fortran block. */
412
413 static void
414 ffeste_end_block_ (ffestw block)
415 {
416 gbe_block b = ffeste_top_block_;
417
418 assert (b);
419 assert (! b->is_stmt);
420 assert (b->block == block);
421 assert (! b->is_stmt);
422
423 ffeste_top_block_ = b->outer;
424
425 free (b);
426
427 ffecom_end_compstmt ();
428 }
429
430 /* Start a Fortran statement.
431
432 Starts a back-end block, so temporaries can be managed, clean-ups
433 properly handled, etc. Nesting of statements *is* allowed -- the
434 handling of I/O items, even implied-DO I/O lists, within a READ,
435 PRINT, or WRITE statement is one example. */
436
437 static void
438 ffeste_start_stmt_(void)
439 {
440 gbe_block b = xmalloc (sizeof (*b));
441
442 b->outer = ffeste_top_block_;
443 b->block = NULL;
444 b->location = input_location;
445 b->is_stmt = TRUE;
446
447 ffeste_top_block_ = b;
448
449 ffecom_start_compstmt ();
450 }
451
452 /* End a Fortran statement. */
453
454 static void
455 ffeste_end_stmt_(void)
456 {
457 gbe_block b = ffeste_top_block_;
458
459 assert (b);
460 assert (b->is_stmt);
461
462 ffeste_top_block_ = b->outer;
463
464 free (b);
465
466 ffecom_end_compstmt ();
467 }
468
469 #else /* ! defined (ENABLE_CHECKING) */
470
471 #define ffeste_start_block_(b) ffecom_start_compstmt ()
472 #define ffeste_end_block_(b) \
473 do \
474 { \
475 ffecom_end_compstmt (); \
476 } while(0)
477 #define ffeste_start_stmt_() ffeste_start_block_(NULL)
478 #define ffeste_end_stmt_() ffeste_end_block_(NULL)
479
480 #endif /* ! defined (ENABLE_CHECKING) */
481
482 /* Begin an iterative DO loop. Pass the block to start if
483 applicable. */
484
485 static void
486 ffeste_begin_iterdo_ (ffestw block, tree *xtvar, tree *xtincr,
487 tree *xitersvar, ffebld var,
488 ffebld start, ffelexToken start_token,
489 ffebld end, ffelexToken end_token,
490 ffebld incr, ffelexToken incr_token,
491 const char *msg)
492 {
493 tree tvar;
494 tree expr;
495 tree tstart;
496 tree tend;
497 tree tincr;
498 tree tincr_saved;
499 tree niters;
500 struct nesting *expanded_loop;
501
502 /* Want to have tvar, tincr, and niters for the whole loop body. */
503
504 if (block)
505 ffeste_start_block_ (block);
506 else
507 ffeste_start_stmt_ ();
508
509 niters = ffecom_make_tempvar (block ? "do" : "impdo",
510 ffecom_integer_type_node,
511 FFETARGET_charactersizeNONE, -1);
512
513 ffecom_prepare_expr (incr);
514 ffecom_prepare_expr_rw (NULL_TREE, var);
515
516 ffecom_prepare_end ();
517
518 tvar = ffecom_expr_rw (NULL_TREE, var);
519 tincr = ffecom_expr (incr);
520
521 if (TREE_CODE (tvar) == ERROR_MARK
522 || TREE_CODE (tincr) == ERROR_MARK)
523 {
524 if (block)
525 {
526 ffeste_end_block_ (block);
527 ffestw_set_do_tvar (block, error_mark_node);
528 }
529 else
530 {
531 ffeste_end_stmt_ ();
532 *xtvar = error_mark_node;
533 }
534 return;
535 }
536
537 /* Check whether incr is known to be zero, complain and fix. */
538
539 if (integer_zerop (tincr) || real_zerop (tincr))
540 {
541 ffebad_start (FFEBAD_DO_STEP_ZERO);
542 ffebad_here (0, ffelex_token_where_line (incr_token),
543 ffelex_token_where_column (incr_token));
544 ffebad_string (msg);
545 ffebad_finish ();
546 tincr = convert (TREE_TYPE (tvar), integer_one_node);
547 }
548
549 tincr_saved = ffecom_save_tree (tincr);
550
551 /* Want to have tstart, tend for just this statement. */
552
553 ffeste_start_stmt_ ();
554
555 ffecom_prepare_expr (start);
556 ffecom_prepare_expr (end);
557
558 ffecom_prepare_end ();
559
560 tstart = ffecom_expr (start);
561 tend = ffecom_expr (end);
562
563 if (TREE_CODE (tstart) == ERROR_MARK
564 || TREE_CODE (tend) == ERROR_MARK)
565 {
566 ffeste_end_stmt_ ();
567
568 if (block)
569 {
570 ffeste_end_block_ (block);
571 ffestw_set_do_tvar (block, error_mark_node);
572 }
573 else
574 {
575 ffeste_end_stmt_ ();
576 *xtvar = error_mark_node;
577 }
578 return;
579 }
580
581 /* For warnings only, nothing else happens here. */
582 {
583 tree try;
584
585 if (! ffe_is_onetrip ())
586 {
587 try = ffecom_2 (MINUS_EXPR, TREE_TYPE (tvar),
588 tend,
589 tstart);
590
591 try = ffecom_2 (PLUS_EXPR, TREE_TYPE (tvar),
592 try,
593 tincr);
594
595 if (TREE_CODE (TREE_TYPE (tvar)) != REAL_TYPE)
596 try = ffecom_2 (TRUNC_DIV_EXPR, integer_type_node, try,
597 tincr);
598 else
599 try = convert (integer_type_node,
600 ffecom_2 (RDIV_EXPR, TREE_TYPE (tvar),
601 try,
602 tincr));
603
604 /* Warn if loop never executed, since we've done the evaluation
605 of the unofficial iteration count already. */
606
607 try = ffecom_truth_value (ffecom_2 (LE_EXPR, integer_type_node,
608 try,
609 convert (TREE_TYPE (tvar),
610 integer_zero_node)));
611
612 if (integer_onep (try))
613 {
614 ffebad_start (FFEBAD_DO_NULL);
615 ffebad_here (0, ffelex_token_where_line (start_token),
616 ffelex_token_where_column (start_token));
617 ffebad_string (msg);
618 ffebad_finish ();
619 }
620 }
621
622 /* Warn if end plus incr would overflow. */
623
624 try = ffecom_2 (PLUS_EXPR, TREE_TYPE (tvar),
625 tend,
626 tincr);
627
628 if ((TREE_CODE_CLASS (TREE_CODE (try)) == 'c')
629 && TREE_CONSTANT_OVERFLOW (try))
630 {
631 ffebad_start (FFEBAD_DO_END_OVERFLOW);
632 ffebad_here (0, ffelex_token_where_line (end_token),
633 ffelex_token_where_column (end_token));
634 ffebad_string (msg);
635 ffebad_finish ();
636 }
637 }
638
639 /* Do the initial assignment into the DO var. */
640
641 tstart = ffecom_save_tree (tstart);
642
643 expr = ffecom_2 (MINUS_EXPR, TREE_TYPE (tvar),
644 tend,
645 tstart);
646
647 if (! ffe_is_onetrip ())
648 {
649 expr = ffecom_2 (PLUS_EXPR, TREE_TYPE (expr),
650 expr,
651 convert (TREE_TYPE (expr), tincr_saved));
652 }
653
654 if (TREE_CODE (TREE_TYPE (tvar)) != REAL_TYPE)
655 expr = ffecom_2 (TRUNC_DIV_EXPR, TREE_TYPE (expr),
656 expr,
657 tincr_saved);
658 else
659 expr = ffecom_2 (RDIV_EXPR, TREE_TYPE (expr),
660 expr,
661 tincr_saved);
662
663 #if 1 /* New, F90-approved approach: convert to default INTEGER. */
664 if (TREE_TYPE (tvar) != error_mark_node)
665 expr = convert (ffecom_integer_type_node, expr);
666 #else /* Old approach; convert to INTEGER unless that's a narrowing. */
667 if ((TREE_TYPE (tvar) != error_mark_node)
668 && ((TREE_CODE (TREE_TYPE (tvar)) != INTEGER_TYPE)
669 || ((TYPE_SIZE (TREE_TYPE (tvar)) != NULL_TREE)
670 && ((TREE_CODE (TYPE_SIZE (TREE_TYPE (tvar)))
671 != INTEGER_CST)
672 || (TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (tvar)))
673 <= TREE_INT_CST_LOW (TYPE_SIZE (ffecom_integer_type_node)))))))
674 /* Convert unless promoting INTEGER type of any kind downward to
675 default INTEGER; else leave as, say, INTEGER*8 (long long int). */
676 expr = convert (ffecom_integer_type_node, expr);
677 #endif
678
679 assert (TYPE_MAIN_VARIANT (TREE_TYPE (niters))
680 == TYPE_MAIN_VARIANT (TREE_TYPE (expr)));
681
682 expr = ffecom_modify (void_type_node, niters, expr);
683 expand_expr_stmt (expr);
684
685 expr = ffecom_modify (void_type_node, tvar, tstart);
686 expand_expr_stmt (expr);
687
688 ffeste_end_stmt_ ();
689
690 expanded_loop = expand_start_loop_continue_elsewhere (!! block);
691 if (block)
692 ffestw_set_do_hook (block, expanded_loop);
693
694 if (! ffe_is_onetrip ())
695 {
696 expr = ffecom_truth_value
697 (ffecom_2 (GE_EXPR, integer_type_node,
698 ffecom_2 (PREDECREMENT_EXPR,
699 TREE_TYPE (niters),
700 niters,
701 convert (TREE_TYPE (niters),
702 ffecom_integer_one_node)),
703 convert (TREE_TYPE (niters),
704 ffecom_integer_zero_node)));
705
706 expand_exit_loop_top_cond (0, expr);
707 }
708
709 if (block)
710 {
711 ffestw_set_do_tvar (block, tvar);
712 ffestw_set_do_incr_saved (block, tincr_saved);
713 ffestw_set_do_count_var (block, niters);
714 }
715 else
716 {
717 *xtvar = tvar;
718 *xtincr = tincr_saved;
719 *xitersvar = niters;
720 }
721 }
722
723 /* End an iterative DO loop. Pass the same iteration variable and increment
724 value trees that were generated in the paired _begin_ call. */
725
726 static void
727 ffeste_end_iterdo_ (ffestw block, tree tvar, tree tincr, tree itersvar)
728 {
729 tree expr;
730 tree niters = itersvar;
731
732 if (tvar == error_mark_node)
733 return;
734
735 expand_loop_continue_here ();
736
737 ffeste_start_stmt_ ();
738
739 if (ffe_is_onetrip ())
740 {
741 expr = ffecom_truth_value
742 (ffecom_2 (GE_EXPR, integer_type_node,
743 ffecom_2 (PREDECREMENT_EXPR,
744 TREE_TYPE (niters),
745 niters,
746 convert (TREE_TYPE (niters),
747 ffecom_integer_one_node)),
748 convert (TREE_TYPE (niters),
749 ffecom_integer_zero_node)));
750
751 expand_exit_loop_if_false (0, expr);
752 }
753
754 expr = ffecom_modify (void_type_node, tvar,
755 ffecom_2 (PLUS_EXPR, TREE_TYPE (tvar),
756 tvar,
757 tincr));
758 expand_expr_stmt (expr);
759
760 /* Lose the stuff we just built. */
761 ffeste_end_stmt_ ();
762
763 expand_end_loop ();
764
765 /* Lose the tvar and incr_saved trees. */
766 if (block)
767 ffeste_end_block_ (block);
768 else
769 ffeste_end_stmt_ ();
770 }
771
772 /* Generate call to run-time I/O routine. */
773
774 static void
775 ffeste_io_call_ (tree call, bool do_check)
776 {
777 /* Generate the call and optional assignment into iostat var. */
778
779 TREE_SIDE_EFFECTS (call) = 1;
780 if (ffeste_io_iostat_ != NULL_TREE)
781 call = ffecom_modify (do_check ? NULL_TREE : void_type_node,
782 ffeste_io_iostat_, call);
783 expand_expr_stmt (call);
784
785 if (! do_check
786 || ffeste_io_abort_ == NULL_TREE
787 || TREE_CODE (ffeste_io_abort_) == ERROR_MARK)
788 return;
789
790 /* Generate optional test. */
791
792 expand_start_cond (ffecom_truth_value (ffeste_io_iostat_), 0);
793 expand_goto (ffeste_io_abort_);
794 expand_end_cond ();
795 }
796
797 /* Handle implied-DO in I/O list.
798
799 Expands code to start up the DO loop. Then for each item in the
800 DO loop, handles appropriately (possibly including recursively calling
801 itself). Then expands code to end the DO loop. */
802
803 static void
804 ffeste_io_impdo_ (ffebld impdo, ffelexToken impdo_token)
805 {
806 ffebld var = ffebld_head (ffebld_right (impdo));
807 ffebld start = ffebld_head (ffebld_trail (ffebld_right (impdo)));
808 ffebld end = ffebld_head (ffebld_trail (ffebld_trail
809 (ffebld_right (impdo))));
810 ffebld incr = ffebld_head (ffebld_trail (ffebld_trail
811 (ffebld_trail (ffebld_right (impdo)))));
812 ffebld list;
813 ffebld item;
814 tree tvar;
815 tree tincr;
816 tree titervar;
817
818 if (incr == NULL)
819 {
820 incr = ffebld_new_conter (ffebld_constant_new_integerdefault_val (1));
821 ffebld_set_info (incr, ffeinfo_new
822 (FFEINFO_basictypeINTEGER,
823 FFEINFO_kindtypeINTEGERDEFAULT,
824 0,
825 FFEINFO_kindENTITY,
826 FFEINFO_whereCONSTANT,
827 FFETARGET_charactersizeNONE));
828 }
829
830 /* Start the DO loop. */
831
832 start = ffeexpr_convert_expr (start, impdo_token, var, impdo_token,
833 FFEEXPR_contextLET);
834 end = ffeexpr_convert_expr (end, impdo_token, var, impdo_token,
835 FFEEXPR_contextLET);
836 incr = ffeexpr_convert_expr (incr, impdo_token, var, impdo_token,
837 FFEEXPR_contextLET);
838
839 ffeste_begin_iterdo_ (NULL, &tvar, &tincr, &titervar, var,
840 start, impdo_token,
841 end, impdo_token,
842 incr, impdo_token,
843 "Implied DO loop");
844
845 /* Handle the list of items. */
846
847 for (list = ffebld_left (impdo); list != NULL; list = ffebld_trail (list))
848 {
849 item = ffebld_head (list);
850 if (item == NULL)
851 continue;
852
853 /* Strip parens off items such as in "READ *,(A)". This is really a bug
854 in the user's code, but I've been told lots of code does this. */
855 while (ffebld_op (item) == FFEBLD_opPAREN)
856 item = ffebld_left (item);
857
858 if (ffebld_op (item) == FFEBLD_opANY)
859 continue;
860
861 if (ffebld_op (item) == FFEBLD_opIMPDO)
862 ffeste_io_impdo_ (item, impdo_token);
863 else
864 {
865 ffeste_start_stmt_ ();
866
867 ffecom_prepare_arg_ptr_to_expr (item);
868
869 ffecom_prepare_end ();
870
871 ffeste_io_call_ ((*ffeste_io_driver_) (item), TRUE);
872
873 ffeste_end_stmt_ ();
874 }
875 }
876
877 /* Generate end of implied-do construct. */
878
879 ffeste_end_iterdo_ (NULL, tvar, tincr, titervar);
880 }
881
882 /* I/O driver for formatted I/O item (do_fio)
883
884 Returns a tree for a CALL_EXPR to the do_fio function, which handles
885 a formatted I/O list item, along with the appropriate arguments for
886 the function. It is up to the caller to set the TREE_SIDE_EFFECTS flag
887 for the CALL_EXPR, expand (emit) the expression, emit any assignment
888 of the result to an IOSTAT= variable, and emit any checking of the
889 result for errors. */
890
891 static tree
892 ffeste_io_dofio_ (ffebld expr)
893 {
894 tree num_elements;
895 tree variable;
896 tree size;
897 tree arglist;
898 ffeinfoBasictype bt;
899 ffeinfoKindtype kt;
900 bool is_complex;
901
902 bt = ffeinfo_basictype (ffebld_info (expr));
903 kt = ffeinfo_kindtype (ffebld_info (expr));
904
905 if ((bt == FFEINFO_basictypeANY)
906 || (kt == FFEINFO_kindtypeANY))
907 return error_mark_node;
908
909 if (bt == FFEINFO_basictypeCOMPLEX)
910 {
911 is_complex = TRUE;
912 bt = FFEINFO_basictypeREAL;
913 }
914 else
915 is_complex = FALSE;
916
917 variable = ffecom_arg_ptr_to_expr (expr, &size);
918
919 if ((variable == error_mark_node)
920 || (size == error_mark_node))
921 return error_mark_node;
922
923 if (size == NULL_TREE) /* Already filled in for CHARACTER type. */
924 { /* "(ftnlen) sizeof(type)" */
925 size = size_binop (CEIL_DIV_EXPR,
926 TYPE_SIZE_UNIT (ffecom_tree_type[bt][kt]),
927 size_int (TYPE_PRECISION (char_type_node)
928 / BITS_PER_UNIT));
929 #if 0 /* Assume that while it is possible that char * is wider than
930 ftnlen, no object in Fortran space can get big enough for its
931 size to be wider than ftnlen. I really hope nobody wastes
932 time debugging a case where it can! */
933 assert (TYPE_PRECISION (ffecom_f2c_ftnlen_type_node)
934 >= TYPE_PRECISION (TREE_TYPE (size)));
935 #endif
936 size = convert (ffecom_f2c_ftnlen_type_node, size);
937 }
938
939 if (ffeinfo_rank (ffebld_info (expr)) == 0
940 || TREE_CODE (TREE_TYPE (TREE_TYPE (variable))) != ARRAY_TYPE)
941 num_elements
942 = is_complex ? ffecom_f2c_ftnlen_two_node : ffecom_f2c_ftnlen_one_node;
943 else
944 {
945 num_elements
946 = size_binop (CEIL_DIV_EXPR,
947 TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (variable))),
948 convert (sizetype, size));
949 num_elements = size_binop (CEIL_DIV_EXPR, num_elements,
950 size_int (TYPE_PRECISION (char_type_node)
951 / BITS_PER_UNIT));
952 num_elements = convert (ffecom_f2c_ftnlen_type_node,
953 num_elements);
954 }
955
956 num_elements
957 = ffecom_1 (ADDR_EXPR, ffecom_f2c_ptr_to_ftnlen_type_node,
958 num_elements);
959
960 variable = convert (string_type_node, variable);
961
962 arglist = build_tree_list (NULL_TREE, num_elements);
963 TREE_CHAIN (arglist) = build_tree_list (NULL_TREE, variable);
964 TREE_CHAIN (TREE_CHAIN (arglist)) = build_tree_list (NULL_TREE, size);
965
966 return ffecom_call_gfrt (FFECOM_gfrtDOFIO, arglist, NULL_TREE);
967 }
968
969 /* I/O driver for list-directed I/O item (do_lio)
970
971 Returns a tree for a CALL_EXPR to the do_lio function, which handles
972 a list-directed I/O list item, along with the appropriate arguments for
973 the function. It is up to the caller to set the TREE_SIDE_EFFECTS flag
974 for the CALL_EXPR, expand (emit) the expression, emit any assignment
975 of the result to an IOSTAT= variable, and emit any checking of the
976 result for errors. */
977
978 static tree
979 ffeste_io_dolio_ (ffebld expr)
980 {
981 tree type_id;
982 tree num_elements;
983 tree variable;
984 tree size;
985 tree arglist;
986 ffeinfoBasictype bt;
987 ffeinfoKindtype kt;
988 int tc;
989
990 bt = ffeinfo_basictype (ffebld_info (expr));
991 kt = ffeinfo_kindtype (ffebld_info (expr));
992
993 if ((bt == FFEINFO_basictypeANY)
994 || (kt == FFEINFO_kindtypeANY))
995 return error_mark_node;
996
997 tc = ffecom_f2c_typecode (bt, kt);
998 assert (tc != -1);
999 type_id = build_int_2 (tc, 0);
1000
1001 type_id
1002 = ffecom_1 (ADDR_EXPR, ffecom_f2c_ptr_to_ftnint_type_node,
1003 convert (ffecom_f2c_ftnint_type_node,
1004 type_id));
1005
1006 variable = ffecom_arg_ptr_to_expr (expr, &size);
1007
1008 if ((type_id == error_mark_node)
1009 || (variable == error_mark_node)
1010 || (size == error_mark_node))
1011 return error_mark_node;
1012
1013 if (size == NULL_TREE) /* Already filled in for CHARACTER type. */
1014 { /* "(ftnlen) sizeof(type)" */
1015 size = size_binop (CEIL_DIV_EXPR,
1016 TYPE_SIZE_UNIT (ffecom_tree_type[bt][kt]),
1017 size_int (TYPE_PRECISION (char_type_node)
1018 / BITS_PER_UNIT));
1019 #if 0 /* Assume that while it is possible that char * is wider than
1020 ftnlen, no object in Fortran space can get big enough for its
1021 size to be wider than ftnlen. I really hope nobody wastes
1022 time debugging a case where it can! */
1023 assert (TYPE_PRECISION (ffecom_f2c_ftnlen_type_node)
1024 >= TYPE_PRECISION (TREE_TYPE (size)));
1025 #endif
1026 size = convert (ffecom_f2c_ftnlen_type_node, size);
1027 }
1028
1029 if (ffeinfo_rank (ffebld_info (expr)) == 0
1030 || TREE_CODE (TREE_TYPE (TREE_TYPE (variable))) != ARRAY_TYPE)
1031 num_elements = ffecom_integer_one_node;
1032 else
1033 {
1034 num_elements
1035 = size_binop (CEIL_DIV_EXPR,
1036 TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (variable))),
1037 convert (sizetype, size));
1038 num_elements = size_binop (CEIL_DIV_EXPR, num_elements,
1039 size_int (TYPE_PRECISION (char_type_node)
1040 / BITS_PER_UNIT));
1041 num_elements = convert (ffecom_f2c_ftnlen_type_node,
1042 num_elements);
1043 }
1044
1045 num_elements
1046 = ffecom_1 (ADDR_EXPR, ffecom_f2c_ptr_to_ftnlen_type_node,
1047 num_elements);
1048
1049 variable = convert (string_type_node, variable);
1050
1051 arglist = build_tree_list (NULL_TREE, type_id);
1052 TREE_CHAIN (arglist) = build_tree_list (NULL_TREE, num_elements);
1053 TREE_CHAIN (TREE_CHAIN (arglist)) = build_tree_list (NULL_TREE, variable);
1054 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (arglist)))
1055 = build_tree_list (NULL_TREE, size);
1056
1057 return ffecom_call_gfrt (FFECOM_gfrtDOLIO, arglist, NULL_TREE);
1058 }
1059
1060 /* I/O driver for unformatted I/O item (do_uio)
1061
1062 Returns a tree for a CALL_EXPR to the do_uio function, which handles
1063 an unformatted I/O list item, along with the appropriate arguments for
1064 the function. It is up to the caller to set the TREE_SIDE_EFFECTS flag
1065 for the CALL_EXPR, expand (emit) the expression, emit any assignment
1066 of the result to an IOSTAT= variable, and emit any checking of the
1067 result for errors. */
1068
1069 static tree
1070 ffeste_io_douio_ (ffebld expr)
1071 {
1072 tree num_elements;
1073 tree variable;
1074 tree size;
1075 tree arglist;
1076 ffeinfoBasictype bt;
1077 ffeinfoKindtype kt;
1078 bool is_complex;
1079
1080 bt = ffeinfo_basictype (ffebld_info (expr));
1081 kt = ffeinfo_kindtype (ffebld_info (expr));
1082
1083 if ((bt == FFEINFO_basictypeANY)
1084 || (kt == FFEINFO_kindtypeANY))
1085 return error_mark_node;
1086
1087 if (bt == FFEINFO_basictypeCOMPLEX)
1088 {
1089 is_complex = TRUE;
1090 bt = FFEINFO_basictypeREAL;
1091 }
1092 else
1093 is_complex = FALSE;
1094
1095 variable = ffecom_arg_ptr_to_expr (expr, &size);
1096
1097 if ((variable == error_mark_node)
1098 || (size == error_mark_node))
1099 return error_mark_node;
1100
1101 if (size == NULL_TREE) /* Already filled in for CHARACTER type. */
1102 { /* "(ftnlen) sizeof(type)" */
1103 size = size_binop (CEIL_DIV_EXPR,
1104 TYPE_SIZE_UNIT (ffecom_tree_type[bt][kt]),
1105 size_int (TYPE_PRECISION (char_type_node)
1106 / BITS_PER_UNIT));
1107 #if 0 /* Assume that while it is possible that char * is wider than
1108 ftnlen, no object in Fortran space can get big enough for its
1109 size to be wider than ftnlen. I really hope nobody wastes
1110 time debugging a case where it can! */
1111 assert (TYPE_PRECISION (ffecom_f2c_ftnlen_type_node)
1112 >= TYPE_PRECISION (TREE_TYPE (size)));
1113 #endif
1114 size = convert (ffecom_f2c_ftnlen_type_node, size);
1115 }
1116
1117 if (ffeinfo_rank (ffebld_info (expr)) == 0
1118 || TREE_CODE (TREE_TYPE (TREE_TYPE (variable))) != ARRAY_TYPE)
1119 num_elements
1120 = is_complex ? ffecom_f2c_ftnlen_two_node : ffecom_f2c_ftnlen_one_node;
1121 else
1122 {
1123 num_elements
1124 = size_binop (CEIL_DIV_EXPR,
1125 TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (variable))),
1126 convert (sizetype, size));
1127 num_elements = size_binop (CEIL_DIV_EXPR, num_elements,
1128 size_int (TYPE_PRECISION (char_type_node)
1129 / BITS_PER_UNIT));
1130 num_elements = convert (ffecom_f2c_ftnlen_type_node,
1131 num_elements);
1132 }
1133
1134 num_elements
1135 = ffecom_1 (ADDR_EXPR, ffecom_f2c_ptr_to_ftnlen_type_node,
1136 num_elements);
1137
1138 variable = convert (string_type_node, variable);
1139
1140 arglist = build_tree_list (NULL_TREE, num_elements);
1141 TREE_CHAIN (arglist) = build_tree_list (NULL_TREE, variable);
1142 TREE_CHAIN (TREE_CHAIN (arglist)) = build_tree_list (NULL_TREE, size);
1143
1144 return ffecom_call_gfrt (FFECOM_gfrtDOUIO, arglist, NULL_TREE);
1145 }
1146
1147 /* Make arglist with ptr to BACKSPACE/ENDFILE/REWIND control list.
1148
1149 Returns a tree suitable as an argument list containing a pointer to
1150 a BACKSPACE/ENDFILE/REWIND control list. First, generates that control
1151 list, if necessary, along with any static and run-time initializations
1152 that are needed as specified by the arguments to this function.
1153
1154 Must ensure that all expressions are prepared before being evaluated,
1155 for any whose evaluation might result in the generation of temporaries.
1156
1157 Note that this means this function causes a transition, within the
1158 current block being code-generated via the back end, from the
1159 declaration of variables (temporaries) to the expanding of expressions,
1160 statements, etc. */
1161
1162 static GTY(()) tree f2c_alist_struct;
1163 static tree
1164 ffeste_io_ialist_ (bool have_err,
1165 ffestvUnit unit,
1166 ffebld unit_expr,
1167 int unit_dflt)
1168 {
1169 tree t;
1170 tree ttype;
1171 tree field;
1172 tree inits, initn;
1173 bool constantp = TRUE;
1174 static tree errfield, unitfield;
1175 tree errinit, unitinit;
1176 tree unitexp;
1177 static int mynumber = 0;
1178
1179 if (f2c_alist_struct == NULL_TREE)
1180 {
1181 tree ref;
1182
1183 ref = make_node (RECORD_TYPE);
1184
1185 errfield = ffecom_decl_field (ref, NULL_TREE, "err",
1186 ffecom_f2c_flag_type_node);
1187 unitfield = ffecom_decl_field (ref, errfield, "unit",
1188 ffecom_f2c_ftnint_type_node);
1189
1190 TYPE_FIELDS (ref) = errfield;
1191 layout_type (ref);
1192
1193 f2c_alist_struct = ref;
1194 }
1195
1196 /* Try to do as much compile-time initialization of the structure
1197 as possible, to save run time. */
1198
1199 ffeste_f2c_init_flag_ (have_err, errinit);
1200
1201 switch (unit)
1202 {
1203 case FFESTV_unitNONE:
1204 case FFESTV_unitASTERISK:
1205 unitinit = build_int_2 (unit_dflt, 0);
1206 unitexp = unitinit;
1207 break;
1208
1209 case FFESTV_unitINTEXPR:
1210 unitexp = ffecom_const_expr (unit_expr);
1211 if (unitexp)
1212 unitinit = unitexp;
1213 else
1214 {
1215 unitinit = ffecom_integer_zero_node;
1216 constantp = FALSE;
1217 }
1218 break;
1219
1220 default:
1221 assert ("bad unit spec" == NULL);
1222 unitinit = ffecom_integer_zero_node;
1223 unitexp = unitinit;
1224 break;
1225 }
1226
1227 inits = build_tree_list ((field = TYPE_FIELDS (f2c_alist_struct)), errinit);
1228 initn = inits;
1229 ffeste_f2c_init_next_ (unitinit);
1230
1231 inits = build_constructor (f2c_alist_struct, inits);
1232 TREE_CONSTANT (inits) = constantp ? 1 : 0;
1233 TREE_STATIC (inits) = 1;
1234
1235 t = build_decl (VAR_DECL,
1236 ffecom_get_invented_identifier ("__g77_alist_%d",
1237 mynumber++),
1238 f2c_alist_struct);
1239 TREE_STATIC (t) = 1;
1240 t = ffecom_start_decl (t, 1);
1241 ffecom_finish_decl (t, inits, 0);
1242
1243 /* Prepare run-time expressions. */
1244
1245 if (! unitexp)
1246 ffecom_prepare_expr (unit_expr);
1247
1248 ffecom_prepare_end ();
1249
1250 /* Now evaluate run-time expressions as needed. */
1251
1252 if (! unitexp)
1253 {
1254 unitexp = ffecom_expr (unit_expr);
1255 ffeste_f2c_compile_ (unitfield, unitexp);
1256 }
1257
1258 ttype = build_pointer_type (TREE_TYPE (t));
1259 t = ffecom_1 (ADDR_EXPR, ttype, t);
1260
1261 t = build_tree_list (NULL_TREE, t);
1262
1263 return t;
1264 }
1265
1266 /* Make arglist with ptr to external-I/O control list.
1267
1268 Returns a tree suitable as an argument list containing a pointer to
1269 an external-I/O control list. First, generates that control
1270 list, if necessary, along with any static and run-time initializations
1271 that are needed as specified by the arguments to this function.
1272
1273 Must ensure that all expressions are prepared before being evaluated,
1274 for any whose evaluation might result in the generation of temporaries.
1275
1276 Note that this means this function causes a transition, within the
1277 current block being code-generated via the back end, from the
1278 declaration of variables (temporaries) to the expanding of expressions,
1279 statements, etc. */
1280
1281 static GTY(()) tree f2c_cilist_struct;
1282 static tree
1283 ffeste_io_cilist_ (bool have_err,
1284 ffestvUnit unit,
1285 ffebld unit_expr,
1286 int unit_dflt,
1287 bool have_end,
1288 ffestvFormat format,
1289 ffestpFile *format_spec,
1290 bool rec,
1291 ffebld rec_expr)
1292 {
1293 tree t;
1294 tree ttype;
1295 tree field;
1296 tree inits, initn;
1297 bool constantp = TRUE;
1298 static tree errfield, unitfield, endfield, formatfield, recfield;
1299 tree errinit, unitinit, endinit, formatinit, recinit;
1300 tree unitexp, formatexp, recexp;
1301 static int mynumber = 0;
1302
1303 if (f2c_cilist_struct == NULL_TREE)
1304 {
1305 tree ref;
1306
1307 ref = make_node (RECORD_TYPE);
1308
1309 errfield = ffecom_decl_field (ref, NULL_TREE, "err",
1310 ffecom_f2c_flag_type_node);
1311 unitfield = ffecom_decl_field (ref, errfield, "unit",
1312 ffecom_f2c_ftnint_type_node);
1313 endfield = ffecom_decl_field (ref, unitfield, "end",
1314 ffecom_f2c_flag_type_node);
1315 formatfield = ffecom_decl_field (ref, endfield, "format",
1316 string_type_node);
1317 recfield = ffecom_decl_field (ref, formatfield, "rec",
1318 ffecom_f2c_ftnint_type_node);
1319
1320 TYPE_FIELDS (ref) = errfield;
1321 layout_type (ref);
1322
1323 f2c_cilist_struct = ref;
1324 }
1325
1326 /* Try to do as much compile-time initialization of the structure
1327 as possible, to save run time. */
1328
1329 ffeste_f2c_init_flag_ (have_err, errinit);
1330
1331 switch (unit)
1332 {
1333 case FFESTV_unitNONE:
1334 case FFESTV_unitASTERISK:
1335 unitinit = build_int_2 (unit_dflt, 0);
1336 unitexp = unitinit;
1337 break;
1338
1339 case FFESTV_unitINTEXPR:
1340 unitexp = ffecom_const_expr (unit_expr);
1341 if (unitexp)
1342 unitinit = unitexp;
1343 else
1344 {
1345 unitinit = ffecom_integer_zero_node;
1346 constantp = FALSE;
1347 }
1348 break;
1349
1350 default:
1351 assert ("bad unit spec" == NULL);
1352 unitinit = ffecom_integer_zero_node;
1353 unitexp = unitinit;
1354 break;
1355 }
1356
1357 switch (format)
1358 {
1359 case FFESTV_formatNONE:
1360 formatinit = null_pointer_node;
1361 formatexp = formatinit;
1362 break;
1363
1364 case FFESTV_formatLABEL:
1365 formatexp = error_mark_node;
1366 formatinit = ffecom_lookup_label (format_spec->u.label);
1367 if ((formatinit == NULL_TREE)
1368 || (TREE_CODE (formatinit) == ERROR_MARK))
1369 break;
1370 formatinit = ffecom_1 (ADDR_EXPR,
1371 build_pointer_type (void_type_node),
1372 formatinit);
1373 TREE_CONSTANT (formatinit) = 1;
1374 break;
1375
1376 case FFESTV_formatCHAREXPR:
1377 formatexp = ffecom_arg_ptr_to_const_expr (format_spec->u.expr, NULL);
1378 if (formatexp)
1379 formatinit = formatexp;
1380 else
1381 {
1382 formatinit = null_pointer_node;
1383 constantp = FALSE;
1384 }
1385 break;
1386
1387 case FFESTV_formatASTERISK:
1388 formatinit = null_pointer_node;
1389 formatexp = formatinit;
1390 break;
1391
1392 case FFESTV_formatINTEXPR:
1393 formatinit = null_pointer_node;
1394 formatexp = ffecom_expr_assign (format_spec->u.expr);
1395 if (GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (formatexp)))
1396 < GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node))))
1397 error ("ASSIGNed FORMAT specifier is too small");
1398 formatexp = convert (string_type_node, formatexp);
1399 break;
1400
1401 case FFESTV_formatNAMELIST:
1402 formatinit = ffecom_expr (format_spec->u.expr);
1403 formatexp = formatinit;
1404 break;
1405
1406 default:
1407 assert ("bad format spec" == NULL);
1408 formatinit = integer_zero_node;
1409 formatexp = formatinit;
1410 break;
1411 }
1412
1413 ffeste_f2c_init_flag_ (have_end, endinit);
1414
1415 if (rec)
1416 recexp = ffecom_const_expr (rec_expr);
1417 else
1418 recexp = ffecom_integer_zero_node;
1419 if (recexp)
1420 recinit = recexp;
1421 else
1422 {
1423 recinit = ffecom_integer_zero_node;
1424 constantp = FALSE;
1425 }
1426
1427 inits = build_tree_list ((field = TYPE_FIELDS (f2c_cilist_struct)), errinit);
1428 initn = inits;
1429 ffeste_f2c_init_next_ (unitinit);
1430 ffeste_f2c_init_next_ (endinit);
1431 ffeste_f2c_init_next_ (formatinit);
1432 ffeste_f2c_init_next_ (recinit);
1433
1434 inits = build_constructor (f2c_cilist_struct, inits);
1435 TREE_CONSTANT (inits) = constantp ? 1 : 0;
1436 TREE_STATIC (inits) = 1;
1437
1438 t = build_decl (VAR_DECL,
1439 ffecom_get_invented_identifier ("__g77_cilist_%d",
1440 mynumber++),
1441 f2c_cilist_struct);
1442 TREE_STATIC (t) = 1;
1443 t = ffecom_start_decl (t, 1);
1444 ffecom_finish_decl (t, inits, 0);
1445
1446 /* Prepare run-time expressions. */
1447
1448 if (! unitexp)
1449 ffecom_prepare_expr (unit_expr);
1450
1451 if (! formatexp)
1452 ffecom_prepare_arg_ptr_to_expr (format_spec->u.expr);
1453
1454 if (! recexp)
1455 ffecom_prepare_expr (rec_expr);
1456
1457 ffecom_prepare_end ();
1458
1459 /* Now evaluate run-time expressions as needed. */
1460
1461 if (! unitexp)
1462 {
1463 unitexp = ffecom_expr (unit_expr);
1464 ffeste_f2c_compile_ (unitfield, unitexp);
1465 }
1466
1467 if (! formatexp)
1468 {
1469 formatexp = ffecom_arg_ptr_to_expr (format_spec->u.expr, NULL);
1470 ffeste_f2c_compile_ (formatfield, formatexp);
1471 }
1472 else if (format == FFESTV_formatINTEXPR)
1473 ffeste_f2c_compile_ (formatfield, formatexp);
1474
1475 if (! recexp)
1476 {
1477 recexp = ffecom_expr (rec_expr);
1478 ffeste_f2c_compile_ (recfield, recexp);
1479 }
1480
1481 ttype = build_pointer_type (TREE_TYPE (t));
1482 t = ffecom_1 (ADDR_EXPR, ttype, t);
1483
1484 t = build_tree_list (NULL_TREE, t);
1485
1486 return t;
1487 }
1488
1489 /* Make arglist with ptr to CLOSE control list.
1490
1491 Returns a tree suitable as an argument list containing a pointer to
1492 a CLOSE-statement control list. First, generates that control
1493 list, if necessary, along with any static and run-time initializations
1494 that are needed as specified by the arguments to this function.
1495
1496 Must ensure that all expressions are prepared before being evaluated,
1497 for any whose evaluation might result in the generation of temporaries.
1498
1499 Note that this means this function causes a transition, within the
1500 current block being code-generated via the back end, from the
1501 declaration of variables (temporaries) to the expanding of expressions,
1502 statements, etc. */
1503
1504 static GTY(()) tree f2c_close_struct;
1505 static tree
1506 ffeste_io_cllist_ (bool have_err,
1507 ffebld unit_expr,
1508 ffestpFile *stat_spec)
1509 {
1510 tree t;
1511 tree ttype;
1512 tree field;
1513 tree inits, initn;
1514 tree ignore; /* Ignore length info for certain fields. */
1515 bool constantp = TRUE;
1516 static tree errfield, unitfield, statfield;
1517 tree errinit, unitinit, statinit;
1518 tree unitexp, statexp;
1519 static int mynumber = 0;
1520
1521 if (f2c_close_struct == NULL_TREE)
1522 {
1523 tree ref;
1524
1525 ref = make_node (RECORD_TYPE);
1526
1527 errfield = ffecom_decl_field (ref, NULL_TREE, "err",
1528 ffecom_f2c_flag_type_node);
1529 unitfield = ffecom_decl_field (ref, errfield, "unit",
1530 ffecom_f2c_ftnint_type_node);
1531 statfield = ffecom_decl_field (ref, unitfield, "stat",
1532 string_type_node);
1533
1534 TYPE_FIELDS (ref) = errfield;
1535 layout_type (ref);
1536
1537 f2c_close_struct = ref;
1538 }
1539
1540 /* Try to do as much compile-time initialization of the structure
1541 as possible, to save run time. */
1542
1543 ffeste_f2c_init_flag_ (have_err, errinit);
1544
1545 unitexp = ffecom_const_expr (unit_expr);
1546 if (unitexp)
1547 unitinit = unitexp;
1548 else
1549 {
1550 unitinit = ffecom_integer_zero_node;
1551 constantp = FALSE;
1552 }
1553
1554 ffeste_f2c_init_charnolen_ (statexp, statinit, stat_spec);
1555
1556 inits = build_tree_list ((field = TYPE_FIELDS (f2c_close_struct)), errinit);
1557 initn = inits;
1558 ffeste_f2c_init_next_ (unitinit);
1559 ffeste_f2c_init_next_ (statinit);
1560
1561 inits = build_constructor (f2c_close_struct, inits);
1562 TREE_CONSTANT (inits) = constantp ? 1 : 0;
1563 TREE_STATIC (inits) = 1;
1564
1565 t = build_decl (VAR_DECL,
1566 ffecom_get_invented_identifier ("__g77_cllist_%d",
1567 mynumber++),
1568 f2c_close_struct);
1569 TREE_STATIC (t) = 1;
1570 t = ffecom_start_decl (t, 1);
1571 ffecom_finish_decl (t, inits, 0);
1572
1573 /* Prepare run-time expressions. */
1574
1575 if (! unitexp)
1576 ffecom_prepare_expr (unit_expr);
1577
1578 if (! statexp)
1579 ffecom_prepare_arg_ptr_to_expr (stat_spec->u.expr);
1580
1581 ffecom_prepare_end ();
1582
1583 /* Now evaluate run-time expressions as needed. */
1584
1585 if (! unitexp)
1586 {
1587 unitexp = ffecom_expr (unit_expr);
1588 ffeste_f2c_compile_ (unitfield, unitexp);
1589 }
1590
1591 ffeste_f2c_compile_charnolen_ (statfield, stat_spec, statexp);
1592
1593 ttype = build_pointer_type (TREE_TYPE (t));
1594 t = ffecom_1 (ADDR_EXPR, ttype, t);
1595
1596 t = build_tree_list (NULL_TREE, t);
1597
1598 return t;
1599 }
1600
1601 /* Make arglist with ptr to internal-I/O control list.
1602
1603 Returns a tree suitable as an argument list containing a pointer to
1604 an internal-I/O control list. First, generates that control
1605 list, if necessary, along with any static and run-time initializations
1606 that are needed as specified by the arguments to this function.
1607
1608 Must ensure that all expressions are prepared before being evaluated,
1609 for any whose evaluation might result in the generation of temporaries.
1610
1611 Note that this means this function causes a transition, within the
1612 current block being code-generated via the back end, from the
1613 declaration of variables (temporaries) to the expanding of expressions,
1614 statements, etc. */
1615
1616 static GTY(()) tree f2c_icilist_struct;
1617 static tree
1618 ffeste_io_icilist_ (bool have_err,
1619 ffebld unit_expr,
1620 bool have_end,
1621 ffestvFormat format,
1622 ffestpFile *format_spec)
1623 {
1624 tree t;
1625 tree ttype;
1626 tree field;
1627 tree inits, initn;
1628 bool constantp = TRUE;
1629 static tree errfield, unitfield, endfield, formatfield, unitlenfield,
1630 unitnumfield;
1631 tree errinit, unitinit, endinit, formatinit, unitleninit, unitnuminit;
1632 tree unitexp, formatexp, unitlenexp, unitnumexp;
1633 static int mynumber = 0;
1634
1635 if (f2c_icilist_struct == NULL_TREE)
1636 {
1637 tree ref;
1638
1639 ref = make_node (RECORD_TYPE);
1640
1641 errfield = ffecom_decl_field (ref, NULL_TREE, "err",
1642 ffecom_f2c_flag_type_node);
1643 unitfield = ffecom_decl_field (ref, errfield, "unit",
1644 string_type_node);
1645 endfield = ffecom_decl_field (ref, unitfield, "end",
1646 ffecom_f2c_flag_type_node);
1647 formatfield = ffecom_decl_field (ref, endfield, "format",
1648 string_type_node);
1649 unitlenfield = ffecom_decl_field (ref, formatfield, "unitlen",
1650 ffecom_f2c_ftnint_type_node);
1651 unitnumfield = ffecom_decl_field (ref, unitlenfield, "unitnum",
1652 ffecom_f2c_ftnint_type_node);
1653
1654 TYPE_FIELDS (ref) = errfield;
1655 layout_type (ref);
1656
1657 f2c_icilist_struct = ref;
1658 }
1659
1660 /* Try to do as much compile-time initialization of the structure
1661 as possible, to save run time. */
1662
1663 ffeste_f2c_init_flag_ (have_err, errinit);
1664
1665 unitexp = ffecom_arg_ptr_to_const_expr (unit_expr, &unitlenexp);
1666 if (unitexp)
1667 unitinit = unitexp;
1668 else
1669 {
1670 unitinit = null_pointer_node;
1671 constantp = FALSE;
1672 }
1673 if (unitlenexp)
1674 unitleninit = unitlenexp;
1675 else
1676 {
1677 unitleninit = ffecom_integer_zero_node;
1678 constantp = FALSE;
1679 }
1680
1681 /* Now see if we can fully initialize the number of elements, or
1682 if we have to compute that at run time. */
1683 if (ffeinfo_rank (ffebld_info (unit_expr)) == 0
1684 || (unitexp
1685 && TREE_CODE (TREE_TYPE (TREE_TYPE (unitexp))) != ARRAY_TYPE))
1686 {
1687 /* Not an array, so just one element. */
1688 unitnuminit = ffecom_integer_one_node;
1689 unitnumexp = unitnuminit;
1690 }
1691 else if (unitexp && unitlenexp)
1692 {
1693 /* An array, but all the info is constant, so compute now. */
1694 unitnuminit
1695 = size_binop (CEIL_DIV_EXPR,
1696 TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (unitexp))),
1697 convert (sizetype, unitlenexp));
1698 unitnuminit = size_binop (CEIL_DIV_EXPR, unitnuminit,
1699 size_int (TYPE_PRECISION (char_type_node)
1700 / BITS_PER_UNIT));
1701 unitnumexp = unitnuminit;
1702 }
1703 else
1704 {
1705 /* Put off computing until run time. */
1706 unitnuminit = ffecom_integer_zero_node;
1707 unitnumexp = NULL_TREE;
1708 constantp = FALSE;
1709 }
1710
1711 switch (format)
1712 {
1713 case FFESTV_formatNONE:
1714 formatinit = null_pointer_node;
1715 formatexp = formatinit;
1716 break;
1717
1718 case FFESTV_formatLABEL:
1719 formatexp = error_mark_node;
1720 formatinit = ffecom_lookup_label (format_spec->u.label);
1721 if ((formatinit == NULL_TREE)
1722 || (TREE_CODE (formatinit) == ERROR_MARK))
1723 break;
1724 formatinit = ffecom_1 (ADDR_EXPR,
1725 build_pointer_type (void_type_node),
1726 formatinit);
1727 TREE_CONSTANT (formatinit) = 1;
1728 break;
1729
1730 case FFESTV_formatCHAREXPR:
1731 ffeste_f2c_init_format_ (formatexp, formatinit, format_spec);
1732 break;
1733
1734 case FFESTV_formatASTERISK:
1735 formatinit = null_pointer_node;
1736 formatexp = formatinit;
1737 break;
1738
1739 case FFESTV_formatINTEXPR:
1740 formatinit = null_pointer_node;
1741 formatexp = ffecom_expr_assign (format_spec->u.expr);
1742 if (GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (formatexp)))
1743 < GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node))))
1744 error ("ASSIGNed FORMAT specifier is too small");
1745 formatexp = convert (string_type_node, formatexp);
1746 break;
1747
1748 default:
1749 assert ("bad format spec" == NULL);
1750 formatinit = ffecom_integer_zero_node;
1751 formatexp = formatinit;
1752 break;
1753 }
1754
1755 ffeste_f2c_init_flag_ (have_end, endinit);
1756
1757 inits = build_tree_list ((field = TYPE_FIELDS (f2c_icilist_struct)),
1758 errinit);
1759 initn = inits;
1760 ffeste_f2c_init_next_ (unitinit);
1761 ffeste_f2c_init_next_ (endinit);
1762 ffeste_f2c_init_next_ (formatinit);
1763 ffeste_f2c_init_next_ (unitleninit);
1764 ffeste_f2c_init_next_ (unitnuminit);
1765
1766 inits = build_constructor (f2c_icilist_struct, inits);
1767 TREE_CONSTANT (inits) = constantp ? 1 : 0;
1768 TREE_STATIC (inits) = 1;
1769
1770 t = build_decl (VAR_DECL,
1771 ffecom_get_invented_identifier ("__g77_icilist_%d",
1772 mynumber++),
1773 f2c_icilist_struct);
1774 TREE_STATIC (t) = 1;
1775 t = ffecom_start_decl (t, 1);
1776 ffecom_finish_decl (t, inits, 0);
1777
1778 /* Prepare run-time expressions. */
1779
1780 if (! unitexp)
1781 ffecom_prepare_arg_ptr_to_expr (unit_expr);
1782
1783 ffeste_f2c_prepare_format_ (format_spec, formatexp);
1784
1785 ffecom_prepare_end ();
1786
1787 /* Now evaluate run-time expressions as needed. */
1788
1789 if (! unitexp || ! unitlenexp)
1790 {
1791 int need_unitexp = (! unitexp);
1792 int need_unitlenexp = (! unitlenexp);
1793
1794 unitexp = ffecom_arg_ptr_to_expr (unit_expr, &unitlenexp);
1795 if (need_unitexp)
1796 ffeste_f2c_compile_ (unitfield, unitexp);
1797 if (need_unitlenexp)
1798 ffeste_f2c_compile_ (unitlenfield, unitlenexp);
1799 }
1800
1801 if (! unitnumexp
1802 && unitexp != error_mark_node
1803 && unitlenexp != error_mark_node)
1804 {
1805 unitnumexp
1806 = size_binop (CEIL_DIV_EXPR,
1807 TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (unitexp))),
1808 convert (sizetype, unitlenexp));
1809 unitnumexp = size_binop (CEIL_DIV_EXPR, unitnumexp,
1810 size_int (TYPE_PRECISION (char_type_node)
1811 / BITS_PER_UNIT));
1812 ffeste_f2c_compile_ (unitnumfield, unitnumexp);
1813 }
1814
1815 if (format == FFESTV_formatINTEXPR)
1816 ffeste_f2c_compile_ (formatfield, formatexp);
1817 else
1818 ffeste_f2c_compile_format_ (formatfield, format_spec, formatexp);
1819
1820 ttype = build_pointer_type (TREE_TYPE (t));
1821 t = ffecom_1 (ADDR_EXPR, ttype, t);
1822
1823 t = build_tree_list (NULL_TREE, t);
1824
1825 return t;
1826 }
1827
1828 /* Make arglist with ptr to INQUIRE control list
1829
1830 Returns a tree suitable as an argument list containing a pointer to
1831 an INQUIRE-statement control list. First, generates that control
1832 list, if necessary, along with any static and run-time initializations
1833 that are needed as specified by the arguments to this function.
1834
1835 Must ensure that all expressions are prepared before being evaluated,
1836 for any whose evaluation might result in the generation of temporaries.
1837
1838 Note that this means this function causes a transition, within the
1839 current block being code-generated via the back end, from the
1840 declaration of variables (temporaries) to the expanding of expressions,
1841 statements, etc. */
1842
1843 static GTY(()) tree f2c_inquire_struct;
1844 static tree
1845 ffeste_io_inlist_ (bool have_err,
1846 ffestpFile *unit_spec,
1847 ffestpFile *file_spec,
1848 ffestpFile *exist_spec,
1849 ffestpFile *open_spec,
1850 ffestpFile *number_spec,
1851 ffestpFile *named_spec,
1852 ffestpFile *name_spec,
1853 ffestpFile *access_spec,
1854 ffestpFile *sequential_spec,
1855 ffestpFile *direct_spec,
1856 ffestpFile *form_spec,
1857 ffestpFile *formatted_spec,
1858 ffestpFile *unformatted_spec,
1859 ffestpFile *recl_spec,
1860 ffestpFile *nextrec_spec,
1861 ffestpFile *blank_spec)
1862 {
1863 tree t;
1864 tree ttype;
1865 tree field;
1866 tree inits, initn;
1867 bool constantp = TRUE;
1868 static tree errfield, unitfield, filefield, filelenfield, existfield,
1869 openfield, numberfield, namedfield, namefield, namelenfield, accessfield,
1870 accesslenfield, sequentialfield, sequentiallenfield, directfield, directlenfield,
1871 formfield, formlenfield, formattedfield, formattedlenfield, unformattedfield,
1872 unformattedlenfield, reclfield, nextrecfield, blankfield, blanklenfield;
1873 tree errinit, unitinit, fileinit, fileleninit, existinit, openinit, numberinit,
1874 namedinit, nameinit, nameleninit, accessinit, accessleninit, sequentialinit,
1875 sequentialleninit, directinit, directleninit, forminit, formleninit,
1876 formattedinit, formattedleninit, unformattedinit, unformattedleninit,
1877 reclinit, nextrecinit, blankinit, blankleninit;
1878 tree
1879 unitexp, fileexp, filelenexp, existexp, openexp, numberexp, namedexp,
1880 nameexp, namelenexp, accessexp, accesslenexp, sequentialexp, sequentiallenexp,
1881 directexp, directlenexp, formexp, formlenexp, formattedexp, formattedlenexp,
1882 unformattedexp, unformattedlenexp, reclexp, nextrecexp, blankexp, blanklenexp;
1883 static int mynumber = 0;
1884
1885 if (f2c_inquire_struct == NULL_TREE)
1886 {
1887 tree ref;
1888
1889 ref = make_node (RECORD_TYPE);
1890
1891 errfield = ffecom_decl_field (ref, NULL_TREE, "err",
1892 ffecom_f2c_flag_type_node);
1893 unitfield = ffecom_decl_field (ref, errfield, "unit",
1894 ffecom_f2c_ftnint_type_node);
1895 filefield = ffecom_decl_field (ref, unitfield, "file",
1896 string_type_node);
1897 filelenfield = ffecom_decl_field (ref, filefield, "filelen",
1898 ffecom_f2c_ftnlen_type_node);
1899 existfield = ffecom_decl_field (ref, filelenfield, "exist",
1900 ffecom_f2c_ptr_to_ftnint_type_node);
1901 openfield = ffecom_decl_field (ref, existfield, "open",
1902 ffecom_f2c_ptr_to_ftnint_type_node);
1903 numberfield = ffecom_decl_field (ref, openfield, "number",
1904 ffecom_f2c_ptr_to_ftnint_type_node);
1905 namedfield = ffecom_decl_field (ref, numberfield, "named",
1906 ffecom_f2c_ptr_to_ftnint_type_node);
1907 namefield = ffecom_decl_field (ref, namedfield, "name",
1908 string_type_node);
1909 namelenfield = ffecom_decl_field (ref, namefield, "namelen",
1910 ffecom_f2c_ftnlen_type_node);
1911 accessfield = ffecom_decl_field (ref, namelenfield, "access",
1912 string_type_node);
1913 accesslenfield = ffecom_decl_field (ref, accessfield, "accesslen",
1914 ffecom_f2c_ftnlen_type_node);
1915 sequentialfield = ffecom_decl_field (ref, accesslenfield, "sequential",
1916 string_type_node);
1917 sequentiallenfield = ffecom_decl_field (ref, sequentialfield,
1918 "sequentiallen",
1919 ffecom_f2c_ftnlen_type_node);
1920 directfield = ffecom_decl_field (ref, sequentiallenfield, "direct",
1921 string_type_node);
1922 directlenfield = ffecom_decl_field (ref, directfield, "directlen",
1923 ffecom_f2c_ftnlen_type_node);
1924 formfield = ffecom_decl_field (ref, directlenfield, "form",
1925 string_type_node);
1926 formlenfield = ffecom_decl_field (ref, formfield, "formlen",
1927 ffecom_f2c_ftnlen_type_node);
1928 formattedfield = ffecom_decl_field (ref, formlenfield, "formatted",
1929 string_type_node);
1930 formattedlenfield = ffecom_decl_field (ref, formattedfield,
1931 "formattedlen",
1932 ffecom_f2c_ftnlen_type_node);
1933 unformattedfield = ffecom_decl_field (ref, formattedlenfield,
1934 "unformatted",
1935 string_type_node);
1936 unformattedlenfield = ffecom_decl_field (ref, unformattedfield,
1937 "unformattedlen",
1938 ffecom_f2c_ftnlen_type_node);
1939 reclfield = ffecom_decl_field (ref, unformattedlenfield, "recl",
1940 ffecom_f2c_ptr_to_ftnint_type_node);
1941 nextrecfield = ffecom_decl_field (ref, reclfield, "nextrec",
1942 ffecom_f2c_ptr_to_ftnint_type_node);
1943 blankfield = ffecom_decl_field (ref, nextrecfield, "blank",
1944 string_type_node);
1945 blanklenfield = ffecom_decl_field (ref, blankfield, "blanklen",
1946 ffecom_f2c_ftnlen_type_node);
1947
1948 TYPE_FIELDS (ref) = errfield;
1949 layout_type (ref);
1950
1951 f2c_inquire_struct = ref;
1952 }
1953
1954 /* Try to do as much compile-time initialization of the structure
1955 as possible, to save run time. */
1956
1957 ffeste_f2c_init_flag_ (have_err, errinit);
1958 ffeste_f2c_init_int_ (unitexp, unitinit, unit_spec);
1959 ffeste_f2c_init_char_ (fileexp, fileinit, filelenexp, fileleninit,
1960 file_spec);
1961 ffeste_f2c_init_ptrtoint_ (existexp, existinit, exist_spec);
1962 ffeste_f2c_init_ptrtoint_ (openexp, openinit, open_spec);
1963 ffeste_f2c_init_ptrtoint_ (numberexp, numberinit, number_spec);
1964 ffeste_f2c_init_ptrtoint_ (namedexp, namedinit, named_spec);
1965 ffeste_f2c_init_char_ (nameexp, nameinit, namelenexp, nameleninit,
1966 name_spec);
1967 ffeste_f2c_init_char_ (accessexp, accessinit, accesslenexp,
1968 accessleninit, access_spec);
1969 ffeste_f2c_init_char_ (sequentialexp, sequentialinit, sequentiallenexp,
1970 sequentialleninit, sequential_spec);
1971 ffeste_f2c_init_char_ (directexp, directinit, directlenexp,
1972 directleninit, direct_spec);
1973 ffeste_f2c_init_char_ (formexp, forminit, formlenexp, formleninit,
1974 form_spec);
1975 ffeste_f2c_init_char_ (formattedexp, formattedinit,
1976 formattedlenexp, formattedleninit, formatted_spec);
1977 ffeste_f2c_init_char_ (unformattedexp, unformattedinit, unformattedlenexp,
1978 unformattedleninit, unformatted_spec);
1979 ffeste_f2c_init_ptrtoint_ (reclexp, reclinit, recl_spec);
1980 ffeste_f2c_init_ptrtoint_ (nextrecexp, nextrecinit, nextrec_spec);
1981 ffeste_f2c_init_char_ (blankexp, blankinit, blanklenexp,
1982 blankleninit, blank_spec);
1983
1984 inits = build_tree_list ((field = TYPE_FIELDS (f2c_inquire_struct)),
1985 errinit);
1986 initn = inits;
1987 ffeste_f2c_init_next_ (unitinit);
1988 ffeste_f2c_init_next_ (fileinit);
1989 ffeste_f2c_init_next_ (fileleninit);
1990 ffeste_f2c_init_next_ (existinit);
1991 ffeste_f2c_init_next_ (openinit);
1992 ffeste_f2c_init_next_ (numberinit);
1993 ffeste_f2c_init_next_ (namedinit);
1994 ffeste_f2c_init_next_ (nameinit);
1995 ffeste_f2c_init_next_ (nameleninit);
1996 ffeste_f2c_init_next_ (accessinit);
1997 ffeste_f2c_init_next_ (accessleninit);
1998 ffeste_f2c_init_next_ (sequentialinit);
1999 ffeste_f2c_init_next_ (sequentialleninit);
2000 ffeste_f2c_init_next_ (directinit);
2001 ffeste_f2c_init_next_ (directleninit);
2002 ffeste_f2c_init_next_ (forminit);
2003 ffeste_f2c_init_next_ (formleninit);
2004 ffeste_f2c_init_next_ (formattedinit);
2005 ffeste_f2c_init_next_ (formattedleninit);
2006 ffeste_f2c_init_next_ (unformattedinit);
2007 ffeste_f2c_init_next_ (unformattedleninit);
2008 ffeste_f2c_init_next_ (reclinit);
2009 ffeste_f2c_init_next_ (nextrecinit);
2010 ffeste_f2c_init_next_ (blankinit);
2011 ffeste_f2c_init_next_ (blankleninit);
2012
2013 inits = build_constructor (f2c_inquire_struct, inits);
2014 TREE_CONSTANT (inits) = constantp ? 1 : 0;
2015 TREE_STATIC (inits) = 1;
2016
2017 t = build_decl (VAR_DECL,
2018 ffecom_get_invented_identifier ("__g77_inlist_%d",
2019 mynumber++),
2020 f2c_inquire_struct);
2021 TREE_STATIC (t) = 1;
2022 t = ffecom_start_decl (t, 1);
2023 ffecom_finish_decl (t, inits, 0);
2024
2025 /* Prepare run-time expressions. */
2026
2027 ffeste_f2c_prepare_int_ (unit_spec, unitexp);
2028 ffeste_f2c_prepare_char_ (file_spec, fileexp);
2029 ffeste_f2c_prepare_ptrtoint_ (exist_spec, existexp);
2030 ffeste_f2c_prepare_ptrtoint_ (open_spec, openexp);
2031 ffeste_f2c_prepare_ptrtoint_ (number_spec, numberexp);
2032 ffeste_f2c_prepare_ptrtoint_ (named_spec, namedexp);
2033 ffeste_f2c_prepare_char_ (name_spec, nameexp);
2034 ffeste_f2c_prepare_char_ (access_spec, accessexp);
2035 ffeste_f2c_prepare_char_ (sequential_spec, sequentialexp);
2036 ffeste_f2c_prepare_char_ (direct_spec, directexp);
2037 ffeste_f2c_prepare_char_ (form_spec, formexp);
2038 ffeste_f2c_prepare_char_ (formatted_spec, formattedexp);
2039 ffeste_f2c_prepare_char_ (unformatted_spec, unformattedexp);
2040 ffeste_f2c_prepare_ptrtoint_ (recl_spec, reclexp);
2041 ffeste_f2c_prepare_ptrtoint_ (nextrec_spec, nextrecexp);
2042 ffeste_f2c_prepare_char_ (blank_spec, blankexp);
2043
2044 ffecom_prepare_end ();
2045
2046 /* Now evaluate run-time expressions as needed. */
2047
2048 ffeste_f2c_compile_int_ (unitfield, unit_spec, unitexp);
2049 ffeste_f2c_compile_char_ (filefield, filelenfield, file_spec,
2050 fileexp, filelenexp);
2051 ffeste_f2c_compile_ptrtoint_ (existfield, exist_spec, existexp);
2052 ffeste_f2c_compile_ptrtoint_ (openfield, open_spec, openexp);
2053 ffeste_f2c_compile_ptrtoint_ (numberfield, number_spec, numberexp);
2054 ffeste_f2c_compile_ptrtoint_ (namedfield, named_spec, namedexp);
2055 ffeste_f2c_compile_char_ (namefield, namelenfield, name_spec, nameexp,
2056 namelenexp);
2057 ffeste_f2c_compile_char_ (accessfield, accesslenfield, access_spec,
2058 accessexp, accesslenexp);
2059 ffeste_f2c_compile_char_ (sequentialfield, sequentiallenfield,
2060 sequential_spec, sequentialexp,
2061 sequentiallenexp);
2062 ffeste_f2c_compile_char_ (directfield, directlenfield, direct_spec,
2063 directexp, directlenexp);
2064 ffeste_f2c_compile_char_ (formfield, formlenfield, form_spec, formexp,
2065 formlenexp);
2066 ffeste_f2c_compile_char_ (formattedfield, formattedlenfield, formatted_spec,
2067 formattedexp, formattedlenexp);
2068 ffeste_f2c_compile_char_ (unformattedfield, unformattedlenfield,
2069 unformatted_spec, unformattedexp,
2070 unformattedlenexp);
2071 ffeste_f2c_compile_ptrtoint_ (reclfield, recl_spec, reclexp);
2072 ffeste_f2c_compile_ptrtoint_ (nextrecfield, nextrec_spec, nextrecexp);
2073 ffeste_f2c_compile_char_ (blankfield, blanklenfield, blank_spec, blankexp,
2074 blanklenexp);
2075
2076 ttype = build_pointer_type (TREE_TYPE (t));
2077 t = ffecom_1 (ADDR_EXPR, ttype, t);
2078
2079 t = build_tree_list (NULL_TREE, t);
2080
2081 return t;
2082 }
2083
2084 /* Make arglist with ptr to OPEN control list
2085
2086 Returns a tree suitable as an argument list containing a pointer to
2087 an OPEN-statement control list. First, generates that control
2088 list, if necessary, along with any static and run-time initializations
2089 that are needed as specified by the arguments to this function.
2090
2091 Must ensure that all expressions are prepared before being evaluated,
2092 for any whose evaluation might result in the generation of temporaries.
2093
2094 Note that this means this function causes a transition, within the
2095 current block being code-generated via the back end, from the
2096 declaration of variables (temporaries) to the expanding of expressions,
2097 statements, etc. */
2098
2099 static GTY(()) tree f2c_open_struct;
2100 static tree
2101 ffeste_io_olist_ (bool have_err,
2102 ffebld unit_expr,
2103 ffestpFile *file_spec,
2104 ffestpFile *stat_spec,
2105 ffestpFile *access_spec,
2106 ffestpFile *form_spec,
2107 ffestpFile *recl_spec,
2108 ffestpFile *blank_spec)
2109 {
2110 tree t;
2111 tree ttype;
2112 tree field;
2113 tree inits, initn;
2114 tree ignore; /* Ignore length info for certain fields. */
2115 bool constantp = TRUE;
2116 static tree errfield, unitfield, filefield, filelenfield, statfield,
2117 accessfield, formfield, reclfield, blankfield;
2118 tree errinit, unitinit, fileinit, fileleninit, statinit, accessinit,
2119 forminit, reclinit, blankinit;
2120 tree
2121 unitexp, fileexp, filelenexp, statexp, accessexp, formexp, reclexp,
2122 blankexp;
2123 static int mynumber = 0;
2124
2125 if (f2c_open_struct == NULL_TREE)
2126 {
2127 tree ref;
2128
2129 ref = make_node (RECORD_TYPE);
2130
2131 errfield = ffecom_decl_field (ref, NULL_TREE, "err",
2132 ffecom_f2c_flag_type_node);
2133 unitfield = ffecom_decl_field (ref, errfield, "unit",
2134 ffecom_f2c_ftnint_type_node);
2135 filefield = ffecom_decl_field (ref, unitfield, "file",
2136 string_type_node);
2137 filelenfield = ffecom_decl_field (ref, filefield, "filelen",
2138 ffecom_f2c_ftnlen_type_node);
2139 statfield = ffecom_decl_field (ref, filelenfield, "stat",
2140 string_type_node);
2141 accessfield = ffecom_decl_field (ref, statfield, "access",
2142 string_type_node);
2143 formfield = ffecom_decl_field (ref, accessfield, "form",
2144 string_type_node);
2145 reclfield = ffecom_decl_field (ref, formfield, "recl",
2146 ffecom_f2c_ftnint_type_node);
2147 blankfield = ffecom_decl_field (ref, reclfield, "blank",
2148 string_type_node);
2149
2150 TYPE_FIELDS (ref) = errfield;
2151 layout_type (ref);
2152
2153 f2c_open_struct = ref;
2154 }
2155
2156 /* Try to do as much compile-time initialization of the structure
2157 as possible, to save run time. */
2158
2159 ffeste_f2c_init_flag_ (have_err, errinit);
2160
2161 unitexp = ffecom_const_expr (unit_expr);
2162 if (unitexp)
2163 unitinit = unitexp;
2164 else
2165 {
2166 unitinit = ffecom_integer_zero_node;
2167 constantp = FALSE;
2168 }
2169
2170 ffeste_f2c_init_char_ (fileexp, fileinit, filelenexp, fileleninit,
2171 file_spec);
2172 ffeste_f2c_init_charnolen_ (statexp, statinit, stat_spec);
2173 ffeste_f2c_init_charnolen_ (accessexp, accessinit, access_spec);
2174 ffeste_f2c_init_charnolen_ (formexp, forminit, form_spec);
2175 ffeste_f2c_init_int_ (reclexp, reclinit, recl_spec);
2176 ffeste_f2c_init_charnolen_ (blankexp, blankinit, blank_spec);
2177
2178 inits = build_tree_list ((field = TYPE_FIELDS (f2c_open_struct)), errinit);
2179 initn = inits;
2180 ffeste_f2c_init_next_ (unitinit);
2181 ffeste_f2c_init_next_ (fileinit);
2182 ffeste_f2c_init_next_ (fileleninit);
2183 ffeste_f2c_init_next_ (statinit);
2184 ffeste_f2c_init_next_ (accessinit);
2185 ffeste_f2c_init_next_ (forminit);
2186 ffeste_f2c_init_next_ (reclinit);
2187 ffeste_f2c_init_next_ (blankinit);
2188
2189 inits = build_constructor (f2c_open_struct, inits);
2190 TREE_CONSTANT (inits) = constantp ? 1 : 0;
2191 TREE_STATIC (inits) = 1;
2192
2193 t = build_decl (VAR_DECL,
2194 ffecom_get_invented_identifier ("__g77_olist_%d",
2195 mynumber++),
2196 f2c_open_struct);
2197 TREE_STATIC (t) = 1;
2198 t = ffecom_start_decl (t, 1);
2199 ffecom_finish_decl (t, inits, 0);
2200
2201 /* Prepare run-time expressions. */
2202
2203 if (! unitexp)
2204 ffecom_prepare_expr (unit_expr);
2205
2206 ffeste_f2c_prepare_char_ (file_spec, fileexp);
2207 ffeste_f2c_prepare_charnolen_ (stat_spec, statexp);
2208 ffeste_f2c_prepare_charnolen_ (access_spec, accessexp);
2209 ffeste_f2c_prepare_charnolen_ (form_spec, formexp);
2210 ffeste_f2c_prepare_int_ (recl_spec, reclexp);
2211 ffeste_f2c_prepare_charnolen_ (blank_spec, blankexp);
2212
2213 ffecom_prepare_end ();
2214
2215 /* Now evaluate run-time expressions as needed. */
2216
2217 if (! unitexp)
2218 {
2219 unitexp = ffecom_expr (unit_expr);
2220 ffeste_f2c_compile_ (unitfield, unitexp);
2221 }
2222
2223 ffeste_f2c_compile_char_ (filefield, filelenfield, file_spec, fileexp,
2224 filelenexp);
2225 ffeste_f2c_compile_charnolen_ (statfield, stat_spec, statexp);
2226 ffeste_f2c_compile_charnolen_ (accessfield, access_spec, accessexp);
2227 ffeste_f2c_compile_charnolen_ (formfield, form_spec, formexp);
2228 ffeste_f2c_compile_int_ (reclfield, recl_spec, reclexp);
2229 ffeste_f2c_compile_charnolen_ (blankfield, blank_spec, blankexp);
2230
2231 ttype = build_pointer_type (TREE_TYPE (t));
2232 t = ffecom_1 (ADDR_EXPR, ttype, t);
2233
2234 t = build_tree_list (NULL_TREE, t);
2235
2236 return t;
2237 }
2238
2239 /* Generate code for BACKSPACE/ENDFILE/REWIND. */
2240
2241 static void
2242 ffeste_subr_beru_ (ffestpBeruStmt *info, ffecomGfrt rt)
2243 {
2244 tree alist;
2245 bool iostat;
2246 bool errl;
2247
2248 ffeste_emit_line_note_ ();
2249
2250 #define specified(something) (info->beru_spec[something].kw_or_val_present)
2251
2252 iostat = specified (FFESTP_beruixIOSTAT);
2253 errl = specified (FFESTP_beruixERR);
2254
2255 #undef specified
2256
2257 /* ~~For now, we assume the unit number is specified and is not ASTERISK,
2258 because the FFE doesn't support BACKSPACE(*) and rejects a BACKSPACE
2259 without any unit specifier. f2c, however, supports the former
2260 construct. When it is time to add this feature to the FFE, which
2261 probably is fairly easy, ffestc_R919 and company will want to pass an
2262 ffestvUnit indicator of FFESTV_unitINTEXPR or _unitASTERISK to
2263 ffeste_R919 and company, and they will want to pass that same value to
2264 this function, and that argument will replace the constant _unitINTEXPR_
2265 in the call below. Right now, the default unit number, 6, is ignored. */
2266
2267 ffeste_start_stmt_ ();
2268
2269 if (errl)
2270 {
2271 /* Have ERR= specification. */
2272
2273 ffeste_io_err_
2274 = ffeste_io_abort_
2275 = ffecom_lookup_label
2276 (info->beru_spec[FFESTP_beruixERR].u.label);
2277 ffeste_io_abort_is_temp_ = FALSE;
2278 }
2279 else
2280 {
2281 /* No ERR= specification. */
2282
2283 ffeste_io_err_ = NULL_TREE;
2284
2285 if ((ffeste_io_abort_is_temp_ = iostat))
2286 ffeste_io_abort_ = ffecom_temp_label ();
2287 else
2288 ffeste_io_abort_ = NULL_TREE;
2289 }
2290
2291 if (iostat)
2292 {
2293 /* Have IOSTAT= specification. */
2294
2295 ffeste_io_iostat_is_temp_ = FALSE;
2296 ffeste_io_iostat_ = ffecom_expr
2297 (info->beru_spec[FFESTP_beruixIOSTAT].u.expr);
2298 }
2299 else if (ffeste_io_abort_ != NULL_TREE)
2300 {
2301 /* Have no IOSTAT= but have ERR=. */
2302
2303 ffeste_io_iostat_is_temp_ = TRUE;
2304 ffeste_io_iostat_
2305 = ffecom_make_tempvar ("beru", ffecom_integer_type_node,
2306 FFETARGET_charactersizeNONE, -1);
2307 }
2308 else
2309 {
2310 /* No IOSTAT= or ERR= specification. */
2311
2312 ffeste_io_iostat_is_temp_ = FALSE;
2313 ffeste_io_iostat_ = NULL_TREE;
2314 }
2315
2316 /* Now prescan, then convert, all the arguments. */
2317
2318 alist = ffeste_io_ialist_ (errl || iostat, FFESTV_unitINTEXPR,
2319 info->beru_spec[FFESTP_beruixUNIT].u.expr, 6);
2320
2321 /* Don't generate "if (iostat != 0) goto label;" if label is temp abort
2322 label, since we're gonna fall through to there anyway. */
2323
2324 ffeste_io_call_ (ffecom_call_gfrt (rt, alist, NULL_TREE),
2325 ! ffeste_io_abort_is_temp_);
2326
2327 /* If we've got a temp label, generate its code here. */
2328
2329 if (ffeste_io_abort_is_temp_)
2330 {
2331 DECL_INITIAL (ffeste_io_abort_) = error_mark_node;
2332 emit_nop ();
2333 expand_label (ffeste_io_abort_);
2334
2335 assert (ffeste_io_err_ == NULL_TREE);
2336 }
2337
2338 ffeste_end_stmt_ ();
2339 }
2340
2341 /* END DO statement
2342
2343 Also invoked by _labeldef_branch_finish_ (or, in cases
2344 of errors, other _labeldef_ functions) when the label definition is
2345 for a DO-target (LOOPEND) label, once per matching/outstanding DO
2346 block on the stack. */
2347
2348 void
2349 ffeste_do (ffestw block)
2350 {
2351 ffeste_emit_line_note_ ();
2352
2353 if (ffestw_do_tvar (block) == 0)
2354 {
2355 expand_end_loop (); /* DO WHILE and just DO. */
2356
2357 ffeste_end_block_ (block);
2358 }
2359 else
2360 ffeste_end_iterdo_ (block,
2361 ffestw_do_tvar (block),
2362 ffestw_do_incr_saved (block),
2363 ffestw_do_count_var (block));
2364 }
2365
2366 /* End of statement following logical IF.
2367
2368 Applies to *only* logical IF, not to IF-THEN. */
2369
2370 void
2371 ffeste_end_R807 ()
2372 {
2373 ffeste_emit_line_note_ ();
2374
2375 expand_end_cond ();
2376
2377 ffeste_end_block_ (NULL);
2378 }
2379
2380 /* Generate "code" for branch label definition. */
2381
2382 void
2383 ffeste_labeldef_branch (ffelab label)
2384 {
2385 tree glabel;
2386
2387 glabel = ffecom_lookup_label (label);
2388 assert (glabel != NULL_TREE);
2389 if (TREE_CODE (glabel) == ERROR_MARK)
2390 return;
2391
2392 assert (DECL_INITIAL (glabel) == NULL_TREE);
2393
2394 DECL_INITIAL (glabel) = error_mark_node;
2395 DECL_SOURCE_FILE (glabel) = ffelab_definition_filename (label);
2396 DECL_SOURCE_LINE (glabel) = ffelab_definition_filelinenum (label);
2397
2398 emit_nop ();
2399
2400 expand_label (glabel);
2401 }
2402
2403 /* Generate "code" for FORMAT label definition. */
2404
2405 void
2406 ffeste_labeldef_format (ffelab label)
2407 {
2408 ffeste_label_formatdef_ = label;
2409 }
2410
2411 /* Assignment statement (outside of WHERE). */
2412
2413 void
2414 ffeste_R737A (ffebld dest, ffebld source)
2415 {
2416 ffeste_check_simple_ ();
2417
2418 ffeste_emit_line_note_ ();
2419
2420 ffeste_start_stmt_ ();
2421
2422 ffecom_expand_let_stmt (dest, source);
2423
2424 ffeste_end_stmt_ ();
2425 }
2426
2427 /* Block IF (IF-THEN) statement. */
2428
2429 void
2430 ffeste_R803 (ffestw block, ffebld expr)
2431 {
2432 tree temp;
2433
2434 ffeste_check_simple_ ();
2435
2436 ffeste_emit_line_note_ ();
2437
2438 ffeste_start_block_ (block);
2439
2440 temp = ffecom_make_tempvar ("ifthen", integer_type_node,
2441 FFETARGET_charactersizeNONE, -1);
2442
2443 ffeste_start_stmt_ ();
2444
2445 ffecom_prepare_expr (expr);
2446
2447 if (ffecom_prepare_end ())
2448 {
2449 tree result;
2450
2451 result = ffecom_modify (void_type_node,
2452 temp,
2453 ffecom_truth_value (ffecom_expr (expr)));
2454
2455 expand_expr_stmt (result);
2456
2457 ffeste_end_stmt_ ();
2458 }
2459 else
2460 {
2461 ffeste_end_stmt_ ();
2462
2463 temp = ffecom_truth_value (ffecom_expr (expr));
2464 }
2465
2466 expand_start_cond (temp, 0);
2467
2468 /* No fake `else' constructs introduced (yet). */
2469 ffestw_set_ifthen_fake_else (block, 0);
2470 }
2471
2472 /* ELSE IF statement. */
2473
2474 void
2475 ffeste_R804 (ffestw block, ffebld expr)
2476 {
2477 tree temp;
2478
2479 ffeste_check_simple_ ();
2480
2481 ffeste_emit_line_note_ ();
2482
2483 /* Since ELSEIF(expr) might require preparations for expr,
2484 implement as ELSE; prepare-expr; IF (expr) THEN ...; ENDIF. */
2485
2486 expand_start_else ();
2487
2488 ffeste_start_block_ (block);
2489
2490 temp = ffecom_make_tempvar ("elseif", integer_type_node,
2491 FFETARGET_charactersizeNONE, -1);
2492
2493 ffeste_start_stmt_ ();
2494
2495 ffecom_prepare_expr (expr);
2496
2497 if (ffecom_prepare_end ())
2498 {
2499 tree result;
2500
2501 result = ffecom_modify (void_type_node,
2502 temp,
2503 ffecom_truth_value (ffecom_expr (expr)));
2504
2505 expand_expr_stmt (result);
2506
2507 ffeste_end_stmt_ ();
2508 }
2509 else
2510 {
2511 /* In this case, we could probably have used expand_start_elseif
2512 instead, saving the need for a fake `else' construct. But,
2513 until it's clear that'd improve performance, it's easier this
2514 way, since we have to expand_start_else before we get to this
2515 test, given the current design. */
2516
2517 ffeste_end_stmt_ ();
2518
2519 temp = ffecom_truth_value (ffecom_expr (expr));
2520 }
2521
2522 expand_start_cond (temp, 0);
2523
2524 /* Increment number of fake `else' constructs introduced. */
2525 ffestw_set_ifthen_fake_else (block,
2526 ffestw_ifthen_fake_else (block) + 1);
2527 }
2528
2529 /* ELSE statement. */
2530
2531 void
2532 ffeste_R805 (ffestw block UNUSED)
2533 {
2534 ffeste_check_simple_ ();
2535
2536 ffeste_emit_line_note_ ();
2537
2538 expand_start_else ();
2539 }
2540
2541 /* END IF statement. */
2542
2543 void
2544 ffeste_R806 (ffestw block)
2545 {
2546 int i = ffestw_ifthen_fake_else (block) + 1;
2547
2548 ffeste_emit_line_note_ ();
2549
2550 for (; i; --i)
2551 {
2552 expand_end_cond ();
2553
2554 ffeste_end_block_ (block);
2555 }
2556 }
2557
2558 /* Logical IF statement. */
2559
2560 void
2561 ffeste_R807 (ffebld expr)
2562 {
2563 tree temp;
2564
2565 ffeste_check_simple_ ();
2566
2567 ffeste_emit_line_note_ ();
2568
2569 ffeste_start_block_ (NULL);
2570
2571 temp = ffecom_make_tempvar ("if", integer_type_node,
2572 FFETARGET_charactersizeNONE, -1);
2573
2574 ffeste_start_stmt_ ();
2575
2576 ffecom_prepare_expr (expr);
2577
2578 if (ffecom_prepare_end ())
2579 {
2580 tree result;
2581
2582 result = ffecom_modify (void_type_node,
2583 temp,
2584 ffecom_truth_value (ffecom_expr (expr)));
2585
2586 expand_expr_stmt (result);
2587
2588 ffeste_end_stmt_ ();
2589 }
2590 else
2591 {
2592 ffeste_end_stmt_ ();
2593
2594 temp = ffecom_truth_value (ffecom_expr (expr));
2595 }
2596
2597 expand_start_cond (temp, 0);
2598 }
2599
2600 /* SELECT CASE statement. */
2601
2602 void
2603 ffeste_R809 (ffestw block, ffebld expr)
2604 {
2605 ffeste_check_simple_ ();
2606
2607 ffeste_emit_line_note_ ();
2608
2609 ffeste_start_block_ (block);
2610
2611 if ((expr == NULL)
2612 || (ffeinfo_basictype (ffebld_info (expr))
2613 == FFEINFO_basictypeANY))
2614 ffestw_set_select_texpr (block, error_mark_node);
2615 else if (ffeinfo_basictype (ffebld_info (expr))
2616 == FFEINFO_basictypeCHARACTER)
2617 {
2618 /* ~~~Someday handle CHARACTER*1, CHARACTER*N */
2619
2620 /* xgettext:no-c-format */
2621 ffebad_start_msg ("SELECT CASE on CHARACTER type (at %0) not supported -- sorry",
2622 FFEBAD_severityFATAL);
2623 ffebad_here (0, ffestw_line (block), ffestw_col (block));
2624 ffebad_finish ();
2625 ffestw_set_select_texpr (block, error_mark_node);
2626 }
2627 else
2628 {
2629 tree result;
2630 tree texpr;
2631
2632 result = ffecom_make_tempvar ("select", ffecom_type_expr (expr),
2633 ffeinfo_size (ffebld_info (expr)),
2634 -1);
2635
2636 ffeste_start_stmt_ ();
2637
2638 ffecom_prepare_expr (expr);
2639
2640 ffecom_prepare_end ();
2641
2642 texpr = ffecom_expr (expr);
2643
2644 assert (TYPE_MAIN_VARIANT (TREE_TYPE (texpr))
2645 == TYPE_MAIN_VARIANT (TREE_TYPE (result)));
2646
2647 texpr = ffecom_modify (void_type_node,
2648 result,
2649 texpr);
2650 expand_expr_stmt (texpr);
2651
2652 ffeste_end_stmt_ ();
2653
2654 expand_start_case (1, result, TREE_TYPE (result),
2655 "SELECT CASE statement");
2656 ffestw_set_select_texpr (block, texpr);
2657 ffestw_set_select_break (block, FALSE);
2658 }
2659 }
2660
2661 /* CASE statement.
2662
2663 If casenum is 0, it's CASE DEFAULT. Else it's the case ranges at
2664 the start of the first_stmt list in the select object at the top of
2665 the stack that match casenum. */
2666
2667 void
2668 ffeste_R810 (ffestw block, unsigned long casenum)
2669 {
2670 ffestwSelect s = ffestw_select (block);
2671 ffestwCase c;
2672 tree texprlow;
2673 tree texprhigh;
2674 tree tlabel;
2675 int pushok;
2676 tree duplicate;
2677
2678 ffeste_check_simple_ ();
2679
2680 if (s->first_stmt == (ffestwCase) &s->first_rel)
2681 c = NULL;
2682 else
2683 c = s->first_stmt;
2684
2685 ffeste_emit_line_note_ ();
2686
2687 if (ffestw_select_texpr (block) == error_mark_node)
2688 return;
2689
2690 /* ~~~Someday handle CHARACTER*1, CHARACTER*N */
2691
2692 tlabel = build_decl (LABEL_DECL, NULL_TREE, NULL_TREE);
2693
2694 if (ffestw_select_break (block))
2695 expand_exit_something ();
2696 else
2697 ffestw_set_select_break (block, TRUE);
2698
2699 if ((c == NULL) || (casenum != c->casenum))
2700 {
2701 if (casenum == 0) /* Intentional CASE DEFAULT. */
2702 {
2703 pushok = pushcase (NULL_TREE, 0, tlabel, &duplicate);
2704 assert (pushok == 0);
2705 }
2706 }
2707 else
2708 do
2709 {
2710 texprlow = (c->low == NULL) ? NULL_TREE
2711 : ffecom_constantunion_with_type (&ffebld_constant_union (c->low),
2712 ffecom_tree_type[s->type][s->kindtype],c->low->consttype);
2713 if (c->low != c->high)
2714 {
2715 texprhigh = (c->high == NULL) ? NULL_TREE
2716 : ffecom_constantunion_with_type (&ffebld_constant_union (c->high),
2717 ffecom_tree_type[s->type][s->kindtype],c->high->consttype);
2718 pushok = pushcase_range (texprlow, texprhigh, convert,
2719 tlabel, &duplicate);
2720 }
2721 else
2722 pushok = pushcase (texprlow, convert, tlabel, &duplicate);
2723 if (pushok == 2)
2724 {
2725 ffebad_start_msg ("SELECT (at %0) has duplicate cases -- check integer overflow of CASE(s)",
2726 FFEBAD_severityFATAL);
2727 ffebad_here (0, ffestw_line (block), ffestw_col (block));
2728 ffebad_finish ();
2729 ffestw_set_select_texpr (block, error_mark_node);
2730 }
2731 c = c->next_stmt;
2732 /* Unlink prev. */
2733 c->previous_stmt->previous_stmt->next_stmt = c;
2734 c->previous_stmt = c->previous_stmt->previous_stmt;
2735 }
2736 while ((c != (ffestwCase) &s->first_rel) && (casenum == c->casenum));
2737 }
2738
2739 /* END SELECT statement. */
2740
2741 void
2742 ffeste_R811 (ffestw block)
2743 {
2744 ffeste_emit_line_note_ ();
2745
2746 /* ~~~Someday handle CHARACTER*1, CHARACTER*N */
2747
2748 if (TREE_CODE (ffestw_select_texpr (block)) != ERROR_MARK)
2749 expand_end_case (ffestw_select_texpr (block));
2750
2751 ffeste_end_block_ (block);
2752 }
2753
2754 /* Iterative DO statement. */
2755
2756 void
2757 ffeste_R819A (ffestw block, ffelab label UNUSED, ffebld var,
2758 ffebld start, ffelexToken start_token,
2759 ffebld end, ffelexToken end_token,
2760 ffebld incr, ffelexToken incr_token)
2761 {
2762 ffeste_check_simple_ ();
2763
2764 ffeste_emit_line_note_ ();
2765
2766 ffeste_begin_iterdo_ (block, NULL, NULL, NULL,
2767 var,
2768 start, start_token,
2769 end, end_token,
2770 incr, incr_token,
2771 "Iterative DO loop");
2772 }
2773
2774 /* DO WHILE statement. */
2775
2776 void
2777 ffeste_R819B (ffestw block, ffelab label UNUSED, ffebld expr)
2778 {
2779 tree result;
2780
2781 ffeste_check_simple_ ();
2782
2783 ffeste_emit_line_note_ ();
2784
2785 ffeste_start_block_ (block);
2786
2787 if (expr)
2788 {
2789 struct nesting *loop;
2790 tree mod;
2791
2792 result = ffecom_make_tempvar ("dowhile", integer_type_node,
2793 FFETARGET_charactersizeNONE, -1);
2794 loop = expand_start_loop (1);
2795
2796 ffeste_start_stmt_ ();
2797
2798 ffecom_prepare_expr (expr);
2799
2800 ffecom_prepare_end ();
2801
2802 mod = ffecom_modify (void_type_node,
2803 result,
2804 ffecom_truth_value (ffecom_expr (expr)));
2805 expand_expr_stmt (mod);
2806
2807 ffeste_end_stmt_ ();
2808
2809 ffestw_set_do_hook (block, loop);
2810 expand_exit_loop_top_cond (0, result);
2811 }
2812 else
2813 ffestw_set_do_hook (block, expand_start_loop (1));
2814
2815 ffestw_set_do_tvar (block, NULL_TREE);
2816 }
2817
2818 /* END DO statement.
2819
2820 This is the MIL-STD 1753 END DO. It's syntactic sugar, similar to
2821 CONTINUE (except that it has to have a label that is the target of
2822 one or more iterative DO statement), not the Fortran-90 structured
2823 END DO, which is handled elsewhere, as is the actual mechanism of
2824 ending an iterative DO statement, even one that ends at a label. */
2825
2826 void
2827 ffeste_R825 ()
2828 {
2829 ffeste_check_simple_ ();
2830
2831 ffeste_emit_line_note_ ();
2832
2833 emit_nop ();
2834 }
2835
2836 /* CYCLE statement. */
2837
2838 void
2839 ffeste_R834 (ffestw block)
2840 {
2841 ffeste_check_simple_ ();
2842
2843 ffeste_emit_line_note_ ();
2844
2845 expand_continue_loop (ffestw_do_hook (block));
2846 }
2847
2848 /* EXIT statement. */
2849
2850 void
2851 ffeste_R835 (ffestw block)
2852 {
2853 ffeste_check_simple_ ();
2854
2855 ffeste_emit_line_note_ ();
2856
2857 expand_exit_loop (ffestw_do_hook (block));
2858 }
2859
2860 /* GOTO statement. */
2861
2862 void
2863 ffeste_R836 (ffelab label)
2864 {
2865 tree glabel;
2866
2867 ffeste_check_simple_ ();
2868
2869 ffeste_emit_line_note_ ();
2870
2871 glabel = ffecom_lookup_label (label);
2872 if ((glabel != NULL_TREE)
2873 && (TREE_CODE (glabel) != ERROR_MARK))
2874 {
2875 expand_goto (glabel);
2876 TREE_USED (glabel) = 1;
2877 }
2878 }
2879
2880 /* Computed GOTO statement. */
2881
2882 void
2883 ffeste_R837 (ffelab *labels, int count, ffebld expr)
2884 {
2885 int i;
2886 tree texpr;
2887 tree value;
2888 tree tlabel;
2889 int pushok;
2890 tree duplicate;
2891
2892 ffeste_check_simple_ ();
2893
2894 ffeste_emit_line_note_ ();
2895
2896 ffeste_start_stmt_ ();
2897
2898 ffecom_prepare_expr (expr);
2899
2900 ffecom_prepare_end ();
2901
2902 texpr = ffecom_expr (expr);
2903
2904 expand_start_case (0, texpr, TREE_TYPE (texpr), "computed GOTO statement");
2905
2906 for (i = 0; i < count; ++i)
2907 {
2908 value = build_int_2 (i + 1, 0);
2909 tlabel = build_decl (LABEL_DECL, NULL_TREE, NULL_TREE);
2910
2911 pushok = pushcase (value, convert, tlabel, &duplicate);
2912 assert (pushok == 0);
2913
2914 tlabel = ffecom_lookup_label (labels[i]);
2915 if ((tlabel == NULL_TREE)
2916 || (TREE_CODE (tlabel) == ERROR_MARK))
2917 continue;
2918
2919 expand_goto (tlabel);
2920 TREE_USED (tlabel) = 1;
2921 }
2922 expand_end_case (texpr);
2923
2924 ffeste_end_stmt_ ();
2925 }
2926
2927 /* ASSIGN statement. */
2928
2929 void
2930 ffeste_R838 (ffelab label, ffebld target)
2931 {
2932 tree expr_tree;
2933 tree label_tree;
2934 tree target_tree;
2935
2936 ffeste_check_simple_ ();
2937
2938 ffeste_emit_line_note_ ();
2939
2940 /* No need to call ffeste_start_stmt_(), as the sorts of expressions
2941 seen here should never require use of temporaries. */
2942
2943 label_tree = ffecom_lookup_label (label);
2944 if ((label_tree != NULL_TREE)
2945 && (TREE_CODE (label_tree) != ERROR_MARK))
2946 {
2947 label_tree = ffecom_1 (ADDR_EXPR,
2948 build_pointer_type (void_type_node),
2949 label_tree);
2950 TREE_CONSTANT (label_tree) = 1;
2951
2952 target_tree = ffecom_expr_assign_w (target);
2953 if (GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (target_tree)))
2954 < GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (label_tree))))
2955 error ("ASSIGN to variable that is too small");
2956
2957 label_tree = convert (TREE_TYPE (target_tree), label_tree);
2958
2959 expr_tree = ffecom_modify (void_type_node,
2960 target_tree,
2961 label_tree);
2962 expand_expr_stmt (expr_tree);
2963 }
2964 }
2965
2966 /* Assigned GOTO statement. */
2967
2968 void
2969 ffeste_R839 (ffebld target)
2970 {
2971 tree t;
2972
2973 ffeste_check_simple_ ();
2974
2975 ffeste_emit_line_note_ ();
2976
2977 /* No need to call ffeste_start_stmt_(), as the sorts of expressions
2978 seen here should never require use of temporaries. */
2979
2980 t = ffecom_expr_assign (target);
2981 if (GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (t)))
2982 < GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node))))
2983 error ("ASSIGNed GOTO target variable is too small");
2984
2985 expand_computed_goto (convert (TREE_TYPE (null_pointer_node), t));
2986 }
2987
2988 /* Arithmetic IF statement. */
2989
2990 void
2991 ffeste_R840 (ffebld expr, ffelab neg, ffelab zero, ffelab pos)
2992 {
2993 tree gneg = ffecom_lookup_label (neg);
2994 tree gzero = ffecom_lookup_label (zero);
2995 tree gpos = ffecom_lookup_label (pos);
2996 tree texpr;
2997
2998 ffeste_check_simple_ ();
2999
3000 ffeste_emit_line_note_ ();
3001
3002 if ((gneg == NULL_TREE) || (gzero == NULL_TREE) || (gpos == NULL_TREE))
3003 return;
3004 if ((TREE_CODE (gneg) == ERROR_MARK)
3005 || (TREE_CODE (gzero) == ERROR_MARK)
3006 || (TREE_CODE (gpos) == ERROR_MARK))
3007 return;
3008
3009 ffeste_start_stmt_ ();
3010
3011 ffecom_prepare_expr (expr);
3012
3013 ffecom_prepare_end ();
3014
3015 if (neg == zero)
3016 {
3017 if (neg == pos)
3018 expand_goto (gzero);
3019 else
3020 {
3021 /* IF (expr.LE.0) THEN GOTO neg/zero ELSE GOTO pos. */
3022 texpr = ffecom_expr (expr);
3023 texpr = ffecom_2 (LE_EXPR, integer_type_node,
3024 texpr,
3025 convert (TREE_TYPE (texpr),
3026 integer_zero_node));
3027 expand_start_cond (ffecom_truth_value (texpr), 0);
3028 expand_goto (gzero);
3029 expand_start_else ();
3030 expand_goto (gpos);
3031 expand_end_cond ();
3032 }
3033 }
3034 else if (neg == pos)
3035 {
3036 /* IF (expr.NE.0) THEN GOTO neg/pos ELSE GOTO zero. */
3037 texpr = ffecom_expr (expr);
3038 texpr = ffecom_2 (NE_EXPR, integer_type_node,
3039 texpr,
3040 convert (TREE_TYPE (texpr),
3041 integer_zero_node));
3042 expand_start_cond (ffecom_truth_value (texpr), 0);
3043 expand_goto (gneg);
3044 expand_start_else ();
3045 expand_goto (gzero);
3046 expand_end_cond ();
3047 }
3048 else if (zero == pos)
3049 {
3050 /* IF (expr.GE.0) THEN GOTO zero/pos ELSE GOTO neg. */
3051 texpr = ffecom_expr (expr);
3052 texpr = ffecom_2 (GE_EXPR, integer_type_node,
3053 texpr,
3054 convert (TREE_TYPE (texpr),
3055 integer_zero_node));
3056 expand_start_cond (ffecom_truth_value (texpr), 0);
3057 expand_goto (gzero);
3058 expand_start_else ();
3059 expand_goto (gneg);
3060 expand_end_cond ();
3061 }
3062 else
3063 {
3064 /* Use a SAVE_EXPR in combo with:
3065 IF (expr.LT.0) THEN GOTO neg
3066 ELSEIF (expr.GT.0) THEN GOTO pos
3067 ELSE GOTO zero. */
3068 tree expr_saved = ffecom_save_tree (ffecom_expr (expr));
3069
3070 texpr = ffecom_2 (LT_EXPR, integer_type_node,
3071 expr_saved,
3072 convert (TREE_TYPE (expr_saved),
3073 integer_zero_node));
3074 expand_start_cond (ffecom_truth_value (texpr), 0);
3075 expand_goto (gneg);
3076 texpr = ffecom_2 (GT_EXPR, integer_type_node,
3077 expr_saved,
3078 convert (TREE_TYPE (expr_saved),
3079 integer_zero_node));
3080 expand_start_elseif (ffecom_truth_value (texpr));
3081 expand_goto (gpos);
3082 expand_start_else ();
3083 expand_goto (gzero);
3084 expand_end_cond ();
3085 }
3086
3087 ffeste_end_stmt_ ();
3088 }
3089
3090 /* CONTINUE statement. */
3091
3092 void
3093 ffeste_R841 ()
3094 {
3095 ffeste_check_simple_ ();
3096
3097 ffeste_emit_line_note_ ();
3098
3099 emit_nop ();
3100 }
3101
3102 /* STOP statement. */
3103
3104 void
3105 ffeste_R842 (ffebld expr)
3106 {
3107 tree callit;
3108 ffelexToken msg;
3109
3110 ffeste_check_simple_ ();
3111
3112 ffeste_emit_line_note_ ();
3113
3114 if ((expr == NULL)
3115 || (ffeinfo_basictype (ffebld_info (expr))
3116 == FFEINFO_basictypeANY))
3117 {
3118 msg = ffelex_token_new_character ("",
3119 ffelex_token_where_line (ffesta_tokens[0]),
3120 ffelex_token_where_column (ffesta_tokens[0]));
3121 expr = ffebld_new_conter (ffebld_constant_new_characterdefault
3122 (msg));
3123 ffelex_token_kill (msg);
3124 ffebld_set_info (expr, ffeinfo_new (FFEINFO_basictypeCHARACTER,
3125 FFEINFO_kindtypeCHARACTERDEFAULT,
3126 0, FFEINFO_kindENTITY,
3127 FFEINFO_whereCONSTANT, 0));
3128 }
3129 else if (ffeinfo_basictype (ffebld_info (expr))
3130 == FFEINFO_basictypeINTEGER)
3131 {
3132 char num[50];
3133
3134 assert (ffebld_op (expr) == FFEBLD_opCONTER);
3135 assert (ffeinfo_kindtype (ffebld_info (expr))
3136 == FFEINFO_kindtypeINTEGERDEFAULT);
3137 sprintf (num, "%" ffetargetIntegerDefault_f "d",
3138 ffebld_constant_integer1 (ffebld_conter (expr)));
3139 msg = ffelex_token_new_character (num,
3140 ffelex_token_where_line (ffesta_tokens[0]),
3141 ffelex_token_where_column (ffesta_tokens[0]));
3142 expr = ffebld_new_conter (ffebld_constant_new_characterdefault (msg));
3143 ffelex_token_kill (msg);
3144 ffebld_set_info (expr, ffeinfo_new (FFEINFO_basictypeCHARACTER,
3145 FFEINFO_kindtypeCHARACTERDEFAULT,
3146 0, FFEINFO_kindENTITY,
3147 FFEINFO_whereCONSTANT, 0));
3148 }
3149 else
3150 {
3151 assert (ffeinfo_basictype (ffebld_info (expr))
3152 == FFEINFO_basictypeCHARACTER);
3153 assert (ffebld_op (expr) == FFEBLD_opCONTER);
3154 assert (ffeinfo_kindtype (ffebld_info (expr))
3155 == FFEINFO_kindtypeCHARACTERDEFAULT);
3156 }
3157
3158 /* No need to call ffeste_start_stmt_(), as the sorts of expressions
3159 seen here should never require use of temporaries. */
3160
3161 callit = ffecom_call_gfrt (FFECOM_gfrtSTOP,
3162 ffecom_list_ptr_to_expr (ffebld_new_item (expr, NULL)),
3163 NULL_TREE);
3164 TREE_SIDE_EFFECTS (callit) = 1;
3165
3166 expand_expr_stmt (callit);
3167 }
3168
3169 /* PAUSE statement. */
3170
3171 void
3172 ffeste_R843 (ffebld expr)
3173 {
3174 tree callit;
3175 ffelexToken msg;
3176
3177 ffeste_check_simple_ ();
3178
3179 ffeste_emit_line_note_ ();
3180
3181 if ((expr == NULL)
3182 || (ffeinfo_basictype (ffebld_info (expr))
3183 == FFEINFO_basictypeANY))
3184 {
3185 msg = ffelex_token_new_character ("",
3186 ffelex_token_where_line (ffesta_tokens[0]),
3187 ffelex_token_where_column (ffesta_tokens[0]));
3188 expr = ffebld_new_conter (ffebld_constant_new_characterdefault (msg));
3189 ffelex_token_kill (msg);
3190 ffebld_set_info (expr, ffeinfo_new (FFEINFO_basictypeCHARACTER,
3191 FFEINFO_kindtypeCHARACTERDEFAULT,
3192 0, FFEINFO_kindENTITY,
3193 FFEINFO_whereCONSTANT, 0));
3194 }
3195 else if (ffeinfo_basictype (ffebld_info (expr)) == FFEINFO_basictypeINTEGER)
3196 {
3197 char num[50];
3198
3199 assert (ffebld_op (expr) == FFEBLD_opCONTER);
3200 assert (ffeinfo_kindtype (ffebld_info (expr))
3201 == FFEINFO_kindtypeINTEGERDEFAULT);
3202 sprintf (num, "%" ffetargetIntegerDefault_f "d",
3203 ffebld_constant_integer1 (ffebld_conter (expr)));
3204 msg = ffelex_token_new_character (num, ffelex_token_where_line (ffesta_tokens[0]),
3205 ffelex_token_where_column (ffesta_tokens[0]));
3206 expr = ffebld_new_conter (ffebld_constant_new_characterdefault (msg));
3207 ffelex_token_kill (msg);
3208 ffebld_set_info (expr, ffeinfo_new (FFEINFO_basictypeCHARACTER,
3209 FFEINFO_kindtypeCHARACTERDEFAULT,
3210 0, FFEINFO_kindENTITY,
3211 FFEINFO_whereCONSTANT, 0));
3212 }
3213 else
3214 {
3215 assert (ffeinfo_basictype (ffebld_info (expr))
3216 == FFEINFO_basictypeCHARACTER);
3217 assert (ffebld_op (expr) == FFEBLD_opCONTER);
3218 assert (ffeinfo_kindtype (ffebld_info (expr))
3219 == FFEINFO_kindtypeCHARACTERDEFAULT);
3220 }
3221
3222 /* No need to call ffeste_start_stmt_(), as the sorts of expressions
3223 seen here should never require use of temporaries. */
3224
3225 callit = ffecom_call_gfrt (FFECOM_gfrtPAUSE,
3226 ffecom_list_ptr_to_expr (ffebld_new_item (expr, NULL)),
3227 NULL_TREE);
3228 TREE_SIDE_EFFECTS (callit) = 1;
3229
3230 expand_expr_stmt (callit);
3231 }
3232
3233 /* OPEN statement. */
3234
3235 void
3236 ffeste_R904 (ffestpOpenStmt *info)
3237 {
3238 tree args;
3239 bool iostat;
3240 bool errl;
3241
3242 ffeste_check_simple_ ();
3243
3244 ffeste_emit_line_note_ ();
3245
3246 #define specified(something) (info->open_spec[something].kw_or_val_present)
3247
3248 iostat = specified (FFESTP_openixIOSTAT);
3249 errl = specified (FFESTP_openixERR);
3250
3251 #undef specified
3252
3253 ffeste_start_stmt_ ();
3254
3255 if (errl)
3256 {
3257 ffeste_io_err_
3258 = ffeste_io_abort_
3259 = ffecom_lookup_label
3260 (info->open_spec[FFESTP_openixERR].u.label);
3261 ffeste_io_abort_is_temp_ = FALSE;
3262 }
3263 else
3264 {
3265 ffeste_io_err_ = NULL_TREE;
3266
3267 if ((ffeste_io_abort_is_temp_ = iostat))
3268 ffeste_io_abort_ = ffecom_temp_label ();
3269 else
3270 ffeste_io_abort_ = NULL_TREE;
3271 }
3272
3273 if (iostat)
3274 {
3275 /* Have IOSTAT= specification. */
3276
3277 ffeste_io_iostat_is_temp_ = FALSE;
3278 ffeste_io_iostat_ = ffecom_expr
3279 (info->open_spec[FFESTP_openixIOSTAT].u.expr);
3280 }
3281 else if (ffeste_io_abort_ != NULL_TREE)
3282 {
3283 /* Have no IOSTAT= but have ERR=. */
3284
3285 ffeste_io_iostat_is_temp_ = TRUE;
3286 ffeste_io_iostat_
3287 = ffecom_make_tempvar ("open", ffecom_integer_type_node,
3288 FFETARGET_charactersizeNONE, -1);
3289 }
3290 else
3291 {
3292 /* No IOSTAT= or ERR= specification. */
3293
3294 ffeste_io_iostat_is_temp_ = FALSE;
3295 ffeste_io_iostat_ = NULL_TREE;
3296 }
3297
3298 /* Now prescan, then convert, all the arguments. */
3299
3300 args = ffeste_io_olist_ (errl || iostat,
3301 info->open_spec[FFESTP_openixUNIT].u.expr,
3302 &info->open_spec[FFESTP_openixFILE],
3303 &info->open_spec[FFESTP_openixSTATUS],
3304 &info->open_spec[FFESTP_openixACCESS],
3305 &info->open_spec[FFESTP_openixFORM],
3306 &info->open_spec[FFESTP_openixRECL],
3307 &info->open_spec[FFESTP_openixBLANK]);
3308
3309 /* Don't generate "if (iostat != 0) goto label;" if label is temp abort
3310 label, since we're gonna fall through to there anyway. */
3311
3312 ffeste_io_call_ (ffecom_call_gfrt (FFECOM_gfrtFOPEN, args, NULL_TREE),
3313 ! ffeste_io_abort_is_temp_);
3314
3315 /* If we've got a temp label, generate its code here. */
3316
3317 if (ffeste_io_abort_is_temp_)
3318 {
3319 DECL_INITIAL (ffeste_io_abort_) = error_mark_node;
3320 emit_nop ();
3321 expand_label (ffeste_io_abort_);
3322
3323 assert (ffeste_io_err_ == NULL_TREE);
3324 }
3325
3326 ffeste_end_stmt_ ();
3327 }
3328
3329 /* CLOSE statement. */
3330
3331 void
3332 ffeste_R907 (ffestpCloseStmt *info)
3333 {
3334 tree args;
3335 bool iostat;
3336 bool errl;
3337
3338 ffeste_check_simple_ ();
3339
3340 ffeste_emit_line_note_ ();
3341
3342 #define specified(something) (info->close_spec[something].kw_or_val_present)
3343
3344 iostat = specified (FFESTP_closeixIOSTAT);
3345 errl = specified (FFESTP_closeixERR);
3346
3347 #undef specified
3348
3349 ffeste_start_stmt_ ();
3350
3351 if (errl)
3352 {
3353 ffeste_io_err_
3354 = ffeste_io_abort_
3355 = ffecom_lookup_label
3356 (info->close_spec[FFESTP_closeixERR].u.label);
3357 ffeste_io_abort_is_temp_ = FALSE;
3358 }
3359 else
3360 {
3361 ffeste_io_err_ = NULL_TREE;
3362
3363 if ((ffeste_io_abort_is_temp_ = iostat))
3364 ffeste_io_abort_ = ffecom_temp_label ();
3365 else
3366 ffeste_io_abort_ = NULL_TREE;
3367 }
3368
3369 if (iostat)
3370 {
3371 /* Have IOSTAT= specification. */
3372
3373 ffeste_io_iostat_is_temp_ = FALSE;
3374 ffeste_io_iostat_ = ffecom_expr
3375 (info->close_spec[FFESTP_closeixIOSTAT].u.expr);
3376 }
3377 else if (ffeste_io_abort_ != NULL_TREE)
3378 {
3379 /* Have no IOSTAT= but have ERR=. */
3380
3381 ffeste_io_iostat_is_temp_ = TRUE;
3382 ffeste_io_iostat_
3383 = ffecom_make_tempvar ("close", ffecom_integer_type_node,
3384 FFETARGET_charactersizeNONE, -1);
3385 }
3386 else
3387 {
3388 /* No IOSTAT= or ERR= specification. */
3389
3390 ffeste_io_iostat_is_temp_ = FALSE;
3391 ffeste_io_iostat_ = NULL_TREE;
3392 }
3393
3394 /* Now prescan, then convert, all the arguments. */
3395
3396 args = ffeste_io_cllist_ (errl || iostat,
3397 info->close_spec[FFESTP_closeixUNIT].u.expr,
3398 &info->close_spec[FFESTP_closeixSTATUS]);
3399
3400 /* Don't generate "if (iostat != 0) goto label;" if label is temp abort
3401 label, since we're gonna fall through to there anyway. */
3402
3403 ffeste_io_call_ (ffecom_call_gfrt (FFECOM_gfrtFCLOS, args, NULL_TREE),
3404 ! ffeste_io_abort_is_temp_);
3405
3406 /* If we've got a temp label, generate its code here. */
3407
3408 if (ffeste_io_abort_is_temp_)
3409 {
3410 DECL_INITIAL (ffeste_io_abort_) = error_mark_node;
3411 emit_nop ();
3412 expand_label (ffeste_io_abort_);
3413
3414 assert (ffeste_io_err_ == NULL_TREE);
3415 }
3416
3417 ffeste_end_stmt_ ();
3418 }
3419
3420 /* READ(...) statement -- start. */
3421
3422 void
3423 ffeste_R909_start (ffestpReadStmt *info, bool only_format UNUSED,
3424 ffestvUnit unit, ffestvFormat format, bool rec,
3425 bool key UNUSED)
3426 {
3427 ffecomGfrt start;
3428 ffecomGfrt end;
3429 tree cilist;
3430 bool iostat;
3431 bool errl;
3432 bool endl;
3433
3434 ffeste_check_start_ ();
3435
3436 ffeste_emit_line_note_ ();
3437
3438 /* First determine the start, per-item, and end run-time functions to
3439 call. The per-item function is picked by choosing an ffeste function
3440 to call to handle a given item; it knows how to generate a call to the
3441 appropriate run-time function, and is called an "I/O driver". */
3442
3443 switch (format)
3444 {
3445 case FFESTV_formatNONE: /* no FMT= */
3446 ffeste_io_driver_ = ffeste_io_douio_;
3447 if (rec)
3448 start = FFECOM_gfrtSRDUE, end = FFECOM_gfrtERDUE;
3449 else
3450 start = FFECOM_gfrtSRSUE, end = FFECOM_gfrtERSUE;
3451 break;
3452
3453 case FFESTV_formatLABEL: /* FMT=10 */
3454 case FFESTV_formatCHAREXPR: /* FMT='(I10)' */
3455 case FFESTV_formatINTEXPR: /* FMT=I [after ASSIGN 10 TO I] */
3456 ffeste_io_driver_ = ffeste_io_dofio_;
3457 if (rec)
3458 start = FFECOM_gfrtSRDFE, end = FFECOM_gfrtERDFE;
3459 else if (unit == FFESTV_unitCHAREXPR)
3460 start = FFECOM_gfrtSRSFI, end = FFECOM_gfrtERSFI;
3461 else
3462 start = FFECOM_gfrtSRSFE, end = FFECOM_gfrtERSFE;
3463 break;
3464
3465 case FFESTV_formatASTERISK: /* FMT=* */
3466 ffeste_io_driver_ = ffeste_io_dolio_;
3467 if (unit == FFESTV_unitCHAREXPR)
3468 start = FFECOM_gfrtSRSLI, end = FFECOM_gfrtERSLI;
3469 else
3470 start = FFECOM_gfrtSRSLE, end = FFECOM_gfrtERSLE;
3471 break;
3472
3473 case FFESTV_formatNAMELIST: /* FMT=FOO or NML=FOO [NAMELIST
3474 /FOO/] */
3475 ffeste_io_driver_ = NULL; /* No start or driver function. */
3476 start = FFECOM_gfrtSRSNE, end = FFECOM_gfrt;
3477 break;
3478
3479 default:
3480 assert ("Weird stuff" == NULL);
3481 start = FFECOM_gfrt, end = FFECOM_gfrt;
3482 break;
3483 }
3484 ffeste_io_endgfrt_ = end;
3485
3486 #define specified(something) (info->read_spec[something].kw_or_val_present)
3487
3488 iostat = specified (FFESTP_readixIOSTAT);
3489 errl = specified (FFESTP_readixERR);
3490 endl = specified (FFESTP_readixEND);
3491
3492 #undef specified
3493
3494 ffeste_start_stmt_ ();
3495
3496 if (errl)
3497 {
3498 /* Have ERR= specification. */
3499
3500 ffeste_io_err_
3501 = ffecom_lookup_label (info->read_spec[FFESTP_readixERR].u.label);
3502
3503 if (endl)
3504 {
3505 /* Have both ERR= and END=. Need a temp label to handle both. */
3506 ffeste_io_end_
3507 = ffecom_lookup_label (info->read_spec[FFESTP_readixEND].u.label);
3508 ffeste_io_abort_is_temp_ = TRUE;
3509 ffeste_io_abort_ = ffecom_temp_label ();
3510 }
3511 else
3512 {
3513 /* Have ERR= but no END=. */
3514 ffeste_io_end_ = NULL_TREE;
3515 if ((ffeste_io_abort_is_temp_ = iostat))
3516 ffeste_io_abort_ = ffecom_temp_label ();
3517 else
3518 ffeste_io_abort_ = ffeste_io_err_;
3519 }
3520 }
3521 else
3522 {
3523 /* No ERR= specification. */
3524
3525 ffeste_io_err_ = NULL_TREE;
3526 if (endl)
3527 {
3528 /* Have END= but no ERR=. */
3529 ffeste_io_end_
3530 = ffecom_lookup_label (info->read_spec[FFESTP_readixEND].u.label);
3531 if ((ffeste_io_abort_is_temp_ = iostat))
3532 ffeste_io_abort_ = ffecom_temp_label ();
3533 else
3534 ffeste_io_abort_ = ffeste_io_end_;
3535 }
3536 else
3537 {
3538 /* Have no ERR= or END=. */
3539
3540 ffeste_io_end_ = NULL_TREE;
3541 if ((ffeste_io_abort_is_temp_ = iostat))
3542 ffeste_io_abort_ = ffecom_temp_label ();
3543 else
3544 ffeste_io_abort_ = NULL_TREE;
3545 }
3546 }
3547
3548 if (iostat)
3549 {
3550 /* Have IOSTAT= specification. */
3551
3552 ffeste_io_iostat_is_temp_ = FALSE;
3553 ffeste_io_iostat_
3554 = ffecom_expr (info->read_spec[FFESTP_readixIOSTAT].u.expr);
3555 }
3556 else if (ffeste_io_abort_ != NULL_TREE)
3557 {
3558 /* Have no IOSTAT= but have ERR= and/or END=. */
3559
3560 ffeste_io_iostat_is_temp_ = TRUE;
3561 ffeste_io_iostat_
3562 = ffecom_make_tempvar ("read", ffecom_integer_type_node,
3563 FFETARGET_charactersizeNONE, -1);
3564 }
3565 else
3566 {
3567 /* No IOSTAT=, ERR=, or END= specification. */
3568
3569 ffeste_io_iostat_is_temp_ = FALSE;
3570 ffeste_io_iostat_ = NULL_TREE;
3571 }
3572
3573 /* Now prescan, then convert, all the arguments. */
3574
3575 if (unit == FFESTV_unitCHAREXPR)
3576 cilist = ffeste_io_icilist_ (errl || iostat,
3577 info->read_spec[FFESTP_readixUNIT].u.expr,
3578 endl || iostat, format,
3579 &info->read_spec[FFESTP_readixFORMAT]);
3580 else
3581 cilist = ffeste_io_cilist_ (errl || iostat, unit,
3582 info->read_spec[FFESTP_readixUNIT].u.expr,
3583 5, endl || iostat, format,
3584 &info->read_spec[FFESTP_readixFORMAT],
3585 rec,
3586 info->read_spec[FFESTP_readixREC].u.expr);
3587
3588 /* If there is no end function, then there are no item functions (i.e.
3589 it's a NAMELIST), and vice versa by the way. In this situation, don't
3590 generate the "if (iostat != 0) goto label;" if the label is temp abort
3591 label, since we're gonna fall through to there anyway. */
3592
3593 ffeste_io_call_ (ffecom_call_gfrt (start, cilist, NULL_TREE),
3594 (! ffeste_io_abort_is_temp_) || (end != FFECOM_gfrt));
3595 }
3596
3597 /* READ statement -- I/O item. */
3598
3599 void
3600 ffeste_R909_item (ffebld expr, ffelexToken expr_token)
3601 {
3602 ffeste_check_item_ ();
3603
3604 if (expr == NULL)
3605 return;
3606
3607 /* Strip parens off items such as in "READ *,(A)". This is really a bug
3608 in the user's code, but I've been told lots of code does this. */
3609 while (ffebld_op (expr) == FFEBLD_opPAREN)
3610 expr = ffebld_left (expr);
3611
3612 if (ffebld_op (expr) == FFEBLD_opANY)
3613 return;
3614
3615 if (ffebld_op (expr) == FFEBLD_opIMPDO)
3616 ffeste_io_impdo_ (expr, expr_token);
3617 else
3618 {
3619 ffeste_start_stmt_ ();
3620
3621 ffecom_prepare_arg_ptr_to_expr (expr);
3622
3623 ffecom_prepare_end ();
3624
3625 ffeste_io_call_ ((*ffeste_io_driver_) (expr), TRUE);
3626
3627 ffeste_end_stmt_ ();
3628 }
3629 }
3630
3631 /* READ statement -- end. */
3632
3633 void
3634 ffeste_R909_finish ()
3635 {
3636 ffeste_check_finish_ ();
3637
3638 /* Don't generate "if (iostat != 0) goto label;" if label is temp abort
3639 label, since we're gonna fall through to there anyway. */
3640
3641 if (ffeste_io_endgfrt_ != FFECOM_gfrt)
3642 ffeste_io_call_ (ffecom_call_gfrt (ffeste_io_endgfrt_, NULL_TREE,
3643 NULL_TREE),
3644 ! ffeste_io_abort_is_temp_);
3645
3646 /* If we've got a temp label, generate its code here and have it fan out
3647 to the END= or ERR= label as appropriate. */
3648
3649 if (ffeste_io_abort_is_temp_)
3650 {
3651 DECL_INITIAL (ffeste_io_abort_) = error_mark_node;
3652 emit_nop ();
3653 expand_label (ffeste_io_abort_);
3654
3655 /* "if (iostat<0) goto end_label;". */
3656
3657 if ((ffeste_io_end_ != NULL_TREE)
3658 && (TREE_CODE (ffeste_io_end_) != ERROR_MARK))
3659 {
3660 expand_start_cond (ffecom_truth_value
3661 (ffecom_2 (LT_EXPR, integer_type_node,
3662 ffeste_io_iostat_,
3663 ffecom_integer_zero_node)),
3664 0);
3665 expand_goto (ffeste_io_end_);
3666 expand_end_cond ();
3667 }
3668
3669 /* "if (iostat>0) goto err_label;". */
3670
3671 if ((ffeste_io_err_ != NULL_TREE)
3672 && (TREE_CODE (ffeste_io_err_) != ERROR_MARK))
3673 {
3674 expand_start_cond (ffecom_truth_value
3675 (ffecom_2 (GT_EXPR, integer_type_node,
3676 ffeste_io_iostat_,
3677 ffecom_integer_zero_node)),
3678 0);
3679 expand_goto (ffeste_io_err_);
3680 expand_end_cond ();
3681 }
3682 }
3683
3684 ffeste_end_stmt_ ();
3685 }
3686
3687 /* WRITE statement -- start. */
3688
3689 void
3690 ffeste_R910_start (ffestpWriteStmt *info, ffestvUnit unit,
3691 ffestvFormat format, bool rec)
3692 {
3693 ffecomGfrt start;
3694 ffecomGfrt end;
3695 tree cilist;
3696 bool iostat;
3697 bool errl;
3698
3699 ffeste_check_start_ ();
3700
3701 ffeste_emit_line_note_ ();
3702
3703 /* First determine the start, per-item, and end run-time functions to
3704 call. The per-item function is picked by choosing an ffeste function
3705 to call to handle a given item; it knows how to generate a call to the
3706 appropriate run-time function, and is called an "I/O driver". */
3707
3708 switch (format)
3709 {
3710 case FFESTV_formatNONE: /* no FMT= */
3711 ffeste_io_driver_ = ffeste_io_douio_;
3712 if (rec)
3713 start = FFECOM_gfrtSWDUE, end = FFECOM_gfrtEWDUE;
3714 else
3715 start = FFECOM_gfrtSWSUE, end = FFECOM_gfrtEWSUE;
3716 break;
3717
3718 case FFESTV_formatLABEL: /* FMT=10 */
3719 case FFESTV_formatCHAREXPR: /* FMT='(I10)' */
3720 case FFESTV_formatINTEXPR: /* FMT=I [after ASSIGN 10 TO I] */
3721 ffeste_io_driver_ = ffeste_io_dofio_;
3722 if (rec)
3723 start = FFECOM_gfrtSWDFE, end = FFECOM_gfrtEWDFE;
3724 else if (unit == FFESTV_unitCHAREXPR)
3725 start = FFECOM_gfrtSWSFI, end = FFECOM_gfrtEWSFI;
3726 else
3727 start = FFECOM_gfrtSWSFE, end = FFECOM_gfrtEWSFE;
3728 break;
3729
3730 case FFESTV_formatASTERISK: /* FMT=* */
3731 ffeste_io_driver_ = ffeste_io_dolio_;
3732 if (unit == FFESTV_unitCHAREXPR)
3733 start = FFECOM_gfrtSWSLI, end = FFECOM_gfrtEWSLI;
3734 else
3735 start = FFECOM_gfrtSWSLE, end = FFECOM_gfrtEWSLE;
3736 break;
3737
3738 case FFESTV_formatNAMELIST: /* FMT=FOO or NML=FOO [NAMELIST
3739 /FOO/] */
3740 ffeste_io_driver_ = NULL; /* No start or driver function. */
3741 start = FFECOM_gfrtSWSNE, end = FFECOM_gfrt;
3742 break;
3743
3744 default:
3745 assert ("Weird stuff" == NULL);
3746 start = FFECOM_gfrt, end = FFECOM_gfrt;
3747 break;
3748 }
3749 ffeste_io_endgfrt_ = end;
3750
3751 #define specified(something) (info->write_spec[something].kw_or_val_present)
3752
3753 iostat = specified (FFESTP_writeixIOSTAT);
3754 errl = specified (FFESTP_writeixERR);
3755
3756 #undef specified
3757
3758 ffeste_start_stmt_ ();
3759
3760 ffeste_io_end_ = NULL_TREE;
3761
3762 if (errl)
3763 {
3764 /* Have ERR= specification. */
3765
3766 ffeste_io_err_
3767 = ffeste_io_abort_
3768 = ffecom_lookup_label
3769 (info->write_spec[FFESTP_writeixERR].u.label);
3770 ffeste_io_abort_is_temp_ = FALSE;
3771 }
3772 else
3773 {
3774 /* No ERR= specification. */
3775
3776 ffeste_io_err_ = NULL_TREE;
3777
3778 if ((ffeste_io_abort_is_temp_ = iostat))
3779 ffeste_io_abort_ = ffecom_temp_label ();
3780 else
3781 ffeste_io_abort_ = NULL_TREE;
3782 }
3783
3784 if (iostat)
3785 {
3786 /* Have IOSTAT= specification. */
3787
3788 ffeste_io_iostat_is_temp_ = FALSE;
3789 ffeste_io_iostat_ = ffecom_expr
3790 (info->write_spec[FFESTP_writeixIOSTAT].u.expr);
3791 }
3792 else if (ffeste_io_abort_ != NULL_TREE)
3793 {
3794 /* Have no IOSTAT= but have ERR=. */
3795
3796 ffeste_io_iostat_is_temp_ = TRUE;
3797 ffeste_io_iostat_
3798 = ffecom_make_tempvar ("write", ffecom_integer_type_node,
3799 FFETARGET_charactersizeNONE, -1);
3800 }
3801 else
3802 {
3803 /* No IOSTAT= or ERR= specification. */
3804
3805 ffeste_io_iostat_is_temp_ = FALSE;
3806 ffeste_io_iostat_ = NULL_TREE;
3807 }
3808
3809 /* Now prescan, then convert, all the arguments. */
3810
3811 if (unit == FFESTV_unitCHAREXPR)
3812 cilist = ffeste_io_icilist_ (errl || iostat,
3813 info->write_spec[FFESTP_writeixUNIT].u.expr,
3814 FALSE, format,
3815 &info->write_spec[FFESTP_writeixFORMAT]);
3816 else
3817 cilist = ffeste_io_cilist_ (errl || iostat, unit,
3818 info->write_spec[FFESTP_writeixUNIT].u.expr,
3819 6, FALSE, format,
3820 &info->write_spec[FFESTP_writeixFORMAT],
3821 rec,
3822 info->write_spec[FFESTP_writeixREC].u.expr);
3823
3824 /* If there is no end function, then there are no item functions (i.e.
3825 it's a NAMELIST), and vice versa by the way. In this situation, don't
3826 generate the "if (iostat != 0) goto label;" if the label is temp abort
3827 label, since we're gonna fall through to there anyway. */
3828
3829 ffeste_io_call_ (ffecom_call_gfrt (start, cilist, NULL_TREE),
3830 (! ffeste_io_abort_is_temp_) || (end != FFECOM_gfrt));
3831 }
3832
3833 /* WRITE statement -- I/O item. */
3834
3835 void
3836 ffeste_R910_item (ffebld expr, ffelexToken expr_token)
3837 {
3838 ffeste_check_item_ ();
3839
3840 if (expr == NULL)
3841 return;
3842
3843 if (ffebld_op (expr) == FFEBLD_opANY)
3844 return;
3845
3846 if (ffebld_op (expr) == FFEBLD_opIMPDO)
3847 ffeste_io_impdo_ (expr, expr_token);
3848 else
3849 {
3850 ffeste_start_stmt_ ();
3851
3852 ffecom_prepare_arg_ptr_to_expr (expr);
3853
3854 ffecom_prepare_end ();
3855
3856 ffeste_io_call_ ((*ffeste_io_driver_) (expr), TRUE);
3857
3858 ffeste_end_stmt_ ();
3859 }
3860 }
3861
3862 /* WRITE statement -- end. */
3863
3864 void
3865 ffeste_R910_finish ()
3866 {
3867 ffeste_check_finish_ ();
3868
3869 /* Don't generate "if (iostat != 0) goto label;" if label is temp abort
3870 label, since we're gonna fall through to there anyway. */
3871
3872 if (ffeste_io_endgfrt_ != FFECOM_gfrt)
3873 ffeste_io_call_ (ffecom_call_gfrt (ffeste_io_endgfrt_, NULL_TREE,
3874 NULL_TREE),
3875 ! ffeste_io_abort_is_temp_);
3876
3877 /* If we've got a temp label, generate its code here. */
3878
3879 if (ffeste_io_abort_is_temp_)
3880 {
3881 DECL_INITIAL (ffeste_io_abort_) = error_mark_node;
3882 emit_nop ();
3883 expand_label (ffeste_io_abort_);
3884
3885 assert (ffeste_io_err_ == NULL_TREE);
3886 }
3887
3888 ffeste_end_stmt_ ();
3889 }
3890
3891 /* PRINT statement -- start. */
3892
3893 void
3894 ffeste_R911_start (ffestpPrintStmt *info, ffestvFormat format)
3895 {
3896 ffecomGfrt start;
3897 ffecomGfrt end;
3898 tree cilist;
3899
3900 ffeste_check_start_ ();
3901
3902 ffeste_emit_line_note_ ();
3903
3904 /* First determine the start, per-item, and end run-time functions to
3905 call. The per-item function is picked by choosing an ffeste function
3906 to call to handle a given item; it knows how to generate a call to the
3907 appropriate run-time function, and is called an "I/O driver". */
3908
3909 switch (format)
3910 {
3911 case FFESTV_formatLABEL: /* FMT=10 */
3912 case FFESTV_formatCHAREXPR: /* FMT='(I10)' */
3913 case FFESTV_formatINTEXPR: /* FMT=I [after ASSIGN 10 TO I] */
3914 ffeste_io_driver_ = ffeste_io_dofio_;
3915 start = FFECOM_gfrtSWSFE, end = FFECOM_gfrtEWSFE;
3916 break;
3917
3918 case FFESTV_formatASTERISK: /* FMT=* */
3919 ffeste_io_driver_ = ffeste_io_dolio_;
3920 start = FFECOM_gfrtSWSLE, end = FFECOM_gfrtEWSLE;
3921 break;
3922
3923 case FFESTV_formatNAMELIST: /* FMT=FOO or NML=FOO [NAMELIST
3924 /FOO/] */
3925 ffeste_io_driver_ = NULL; /* No start or driver function. */
3926 start = FFECOM_gfrtSWSNE, end = FFECOM_gfrt;
3927 break;
3928
3929 default:
3930 assert ("Weird stuff" == NULL);
3931 start = FFECOM_gfrt, end = FFECOM_gfrt;
3932 break;
3933 }
3934 ffeste_io_endgfrt_ = end;
3935
3936 ffeste_start_stmt_ ();
3937
3938 ffeste_io_end_ = NULL_TREE;
3939 ffeste_io_err_ = NULL_TREE;
3940 ffeste_io_abort_ = NULL_TREE;
3941 ffeste_io_abort_is_temp_ = FALSE;
3942 ffeste_io_iostat_is_temp_ = FALSE;
3943 ffeste_io_iostat_ = NULL_TREE;
3944
3945 /* Now prescan, then convert, all the arguments. */
3946
3947 cilist = ffeste_io_cilist_ (FALSE, FFESTV_unitNONE, NULL, 6, FALSE, format,
3948 &info->print_spec[FFESTP_printixFORMAT],
3949 FALSE, NULL);
3950
3951 /* If there is no end function, then there are no item functions (i.e.
3952 it's a NAMELIST), and vice versa by the way. In this situation, don't
3953 generate the "if (iostat != 0) goto label;" if the label is temp abort
3954 label, since we're gonna fall through to there anyway. */
3955
3956 ffeste_io_call_ (ffecom_call_gfrt (start, cilist, NULL_TREE),
3957 (! ffeste_io_abort_is_temp_) || (end != FFECOM_gfrt));
3958 }
3959
3960 /* PRINT statement -- I/O item. */
3961
3962 void
3963 ffeste_R911_item (ffebld expr, ffelexToken expr_token)
3964 {
3965 ffeste_check_item_ ();
3966
3967 if (expr == NULL)
3968 return;
3969
3970 if (ffebld_op (expr) == FFEBLD_opANY)
3971 return;
3972
3973 if (ffebld_op (expr) == FFEBLD_opIMPDO)
3974 ffeste_io_impdo_ (expr, expr_token);
3975 else
3976 {
3977 ffeste_start_stmt_ ();
3978
3979 ffecom_prepare_arg_ptr_to_expr (expr);
3980
3981 ffecom_prepare_end ();
3982
3983 ffeste_io_call_ ((*ffeste_io_driver_) (expr), TRUE);
3984
3985 ffeste_end_stmt_ ();
3986 }
3987 }
3988
3989 /* PRINT statement -- end. */
3990
3991 void
3992 ffeste_R911_finish ()
3993 {
3994 ffeste_check_finish_ ();
3995
3996 if (ffeste_io_endgfrt_ != FFECOM_gfrt)
3997 ffeste_io_call_ (ffecom_call_gfrt (ffeste_io_endgfrt_, NULL_TREE,
3998 NULL_TREE),
3999 FALSE);
4000
4001 ffeste_end_stmt_ ();
4002 }
4003
4004 /* BACKSPACE statement. */
4005
4006 void
4007 ffeste_R919 (ffestpBeruStmt *info)
4008 {
4009 ffeste_check_simple_ ();
4010
4011 ffeste_subr_beru_ (info, FFECOM_gfrtFBACK);
4012 }
4013
4014 /* ENDFILE statement. */
4015
4016 void
4017 ffeste_R920 (ffestpBeruStmt *info)
4018 {
4019 ffeste_check_simple_ ();
4020
4021 ffeste_subr_beru_ (info, FFECOM_gfrtFEND);
4022 }
4023
4024 /* REWIND statement. */
4025
4026 void
4027 ffeste_R921 (ffestpBeruStmt *info)
4028 {
4029 ffeste_check_simple_ ();
4030
4031 ffeste_subr_beru_ (info, FFECOM_gfrtFREW);
4032 }
4033
4034 /* INQUIRE statement (non-IOLENGTH version). */
4035
4036 void
4037 ffeste_R923A (ffestpInquireStmt *info, bool by_file UNUSED)
4038 {
4039 tree args;
4040 bool iostat;
4041 bool errl;
4042
4043 ffeste_check_simple_ ();
4044
4045 ffeste_emit_line_note_ ();
4046
4047 #define specified(something) (info->inquire_spec[something].kw_or_val_present)
4048
4049 iostat = specified (FFESTP_inquireixIOSTAT);
4050 errl = specified (FFESTP_inquireixERR);
4051
4052 #undef specified
4053
4054 ffeste_start_stmt_ ();
4055
4056 if (errl)
4057 {
4058 ffeste_io_err_
4059 = ffeste_io_abort_
4060 = ffecom_lookup_label
4061 (info->inquire_spec[FFESTP_inquireixERR].u.label);
4062 ffeste_io_abort_is_temp_ = FALSE;
4063 }
4064 else
4065 {
4066 ffeste_io_err_ = NULL_TREE;
4067
4068 if ((ffeste_io_abort_is_temp_ = iostat))
4069 ffeste_io_abort_ = ffecom_temp_label ();
4070 else
4071 ffeste_io_abort_ = NULL_TREE;
4072 }
4073
4074 if (iostat)
4075 {
4076 /* Have IOSTAT= specification. */
4077
4078 ffeste_io_iostat_is_temp_ = FALSE;
4079 ffeste_io_iostat_ = ffecom_expr
4080 (info->inquire_spec[FFESTP_inquireixIOSTAT].u.expr);
4081 }
4082 else if (ffeste_io_abort_ != NULL_TREE)
4083 {
4084 /* Have no IOSTAT= but have ERR=. */
4085
4086 ffeste_io_iostat_is_temp_ = TRUE;
4087 ffeste_io_iostat_
4088 = ffecom_make_tempvar ("inquire", ffecom_integer_type_node,
4089 FFETARGET_charactersizeNONE, -1);
4090 }
4091 else
4092 {
4093 /* No IOSTAT= or ERR= specification. */
4094
4095 ffeste_io_iostat_is_temp_ = FALSE;
4096 ffeste_io_iostat_ = NULL_TREE;
4097 }
4098
4099 /* Now prescan, then convert, all the arguments. */
4100
4101 args
4102 = ffeste_io_inlist_ (errl || iostat,
4103 &info->inquire_spec[FFESTP_inquireixUNIT],
4104 &info->inquire_spec[FFESTP_inquireixFILE],
4105 &info->inquire_spec[FFESTP_inquireixEXIST],
4106 &info->inquire_spec[FFESTP_inquireixOPENED],
4107 &info->inquire_spec[FFESTP_inquireixNUMBER],
4108 &info->inquire_spec[FFESTP_inquireixNAMED],
4109 &info->inquire_spec[FFESTP_inquireixNAME],
4110 &info->inquire_spec[FFESTP_inquireixACCESS],
4111 &info->inquire_spec[FFESTP_inquireixSEQUENTIAL],
4112 &info->inquire_spec[FFESTP_inquireixDIRECT],
4113 &info->inquire_spec[FFESTP_inquireixFORM],
4114 &info->inquire_spec[FFESTP_inquireixFORMATTED],
4115 &info->inquire_spec[FFESTP_inquireixUNFORMATTED],
4116 &info->inquire_spec[FFESTP_inquireixRECL],
4117 &info->inquire_spec[FFESTP_inquireixNEXTREC],
4118 &info->inquire_spec[FFESTP_inquireixBLANK]);
4119
4120 /* Don't generate "if (iostat != 0) goto label;" if label is temp abort
4121 label, since we're gonna fall through to there anyway. */
4122
4123 ffeste_io_call_ (ffecom_call_gfrt (FFECOM_gfrtFINQU, args, NULL_TREE),
4124 ! ffeste_io_abort_is_temp_);
4125
4126 /* If we've got a temp label, generate its code here. */
4127
4128 if (ffeste_io_abort_is_temp_)
4129 {
4130 DECL_INITIAL (ffeste_io_abort_) = error_mark_node;
4131 emit_nop ();
4132 expand_label (ffeste_io_abort_);
4133
4134 assert (ffeste_io_err_ == NULL_TREE);
4135 }
4136
4137 ffeste_end_stmt_ ();
4138 }
4139
4140 /* INQUIRE(IOLENGTH=expr) statement -- start. */
4141
4142 void
4143 ffeste_R923B_start (ffestpInquireStmt *info UNUSED)
4144 {
4145 ffeste_check_start_ ();
4146
4147 assert ("INQUIRE(IOLENGTH=<var>) not implemented yet! ~~~" == NULL);
4148
4149 ffeste_emit_line_note_ ();
4150 }
4151
4152 /* INQUIRE(IOLENGTH=expr) statement -- I/O item. */
4153
4154 void
4155 ffeste_R923B_item (ffebld expr UNUSED)
4156 {
4157 ffeste_check_item_ ();
4158 }
4159
4160 /* INQUIRE(IOLENGTH=expr) statement -- end. */
4161
4162 void
4163 ffeste_R923B_finish ()
4164 {
4165 ffeste_check_finish_ ();
4166 }
4167
4168 /* ffeste_R1001 -- FORMAT statement
4169
4170 ffeste_R1001(format_list); */
4171
4172 void
4173 ffeste_R1001 (ffests s)
4174 {
4175 tree t;
4176 tree ttype;
4177 tree maxindex;
4178 tree var;
4179
4180 ffeste_check_simple_ ();
4181
4182 assert (ffeste_label_formatdef_ != NULL);
4183
4184 ffeste_emit_line_note_ ();
4185
4186 t = build_string (ffests_length (s), ffests_text (s));
4187
4188 TREE_TYPE (t)
4189 = build_type_variant (build_array_type
4190 (char_type_node,
4191 build_range_type (integer_type_node,
4192 integer_one_node,
4193 build_int_2 (ffests_length (s),
4194 0))),
4195 1, 0);
4196 TREE_CONSTANT (t) = 1;
4197 TREE_STATIC (t) = 1;
4198
4199 var = ffecom_lookup_label (ffeste_label_formatdef_);
4200 if ((var != NULL_TREE)
4201 && (TREE_CODE (var) == VAR_DECL))
4202 {
4203 DECL_INITIAL (var) = t;
4204 maxindex = build_int_2 (ffests_length (s) - 1, 0);
4205 ttype = TREE_TYPE (var);
4206 TYPE_DOMAIN (ttype) = build_range_type (integer_type_node,
4207 integer_zero_node,
4208 maxindex);
4209 if (!TREE_TYPE (maxindex))
4210 TREE_TYPE (maxindex) = TYPE_DOMAIN (ttype);
4211 layout_type (ttype);
4212 rest_of_decl_compilation (var, NULL, 1, 0);
4213 expand_decl (var);
4214 expand_decl_init (var);
4215 }
4216
4217 ffeste_label_formatdef_ = NULL;
4218 }
4219
4220 /* END PROGRAM. */
4221
4222 void
4223 ffeste_R1103 ()
4224 {
4225 }
4226
4227 /* END BLOCK DATA. */
4228
4229 void
4230 ffeste_R1112 ()
4231 {
4232 }
4233
4234 /* CALL statement. */
4235
4236 void
4237 ffeste_R1212 (ffebld expr)
4238 {
4239 ffebld args;
4240 ffebld arg;
4241 ffebld labels = NULL; /* First in list of LABTERs. */
4242 ffebld prevlabels = NULL;
4243 ffebld prevargs = NULL;
4244
4245 ffeste_check_simple_ ();
4246
4247 args = ffebld_right (expr);
4248
4249 ffeste_emit_line_note_ ();
4250
4251 /* Here we split the list at ffebld_right(expr) into two lists: one at
4252 ffebld_right(expr) consisting of all items that are not LABTERs, the
4253 other at labels consisting of all items that are LABTERs. Then, if
4254 the latter list is NULL, we have an ordinary call, else we have a call
4255 with alternate returns. */
4256
4257 for (args = ffebld_right (expr); args != NULL; args = ffebld_trail (args))
4258 {
4259 if (((arg = ffebld_head (args)) == NULL)
4260 || (ffebld_op (arg) != FFEBLD_opLABTER))
4261 {
4262 if (prevargs == NULL)
4263 {
4264 prevargs = args;
4265 ffebld_set_right (expr, args);
4266 }
4267 else
4268 {
4269 ffebld_set_trail (prevargs, args);
4270 prevargs = args;
4271 }
4272 }
4273 else
4274 {
4275 if (prevlabels == NULL)
4276 {
4277 prevlabels = labels = args;
4278 }
4279 else
4280 {
4281 ffebld_set_trail (prevlabels, args);
4282 prevlabels = args;
4283 }
4284 }
4285 }
4286 if (prevlabels == NULL)
4287 labels = NULL;
4288 else
4289 ffebld_set_trail (prevlabels, NULL);
4290 if (prevargs == NULL)
4291 ffebld_set_right (expr, NULL);
4292 else
4293 ffebld_set_trail (prevargs, NULL);
4294
4295 ffeste_start_stmt_ ();
4296
4297 /* No temporaries are actually needed at this level, but we go
4298 through the motions anyway, just to be sure in case they do
4299 get made. Temporaries needed for arguments should be in the
4300 scopes of inner blocks, and if clean-up actions are supported,
4301 such as CALL-ing an intrinsic that writes to an argument of one
4302 type when a variable of a different type is provided (requiring
4303 assignment to the variable from a temporary after the library
4304 routine returns), the clean-up must be done by the expression
4305 evaluator, generally, to handle alternate returns (which we hope
4306 won't ever be supported by intrinsics, but might be a similar
4307 issue, such as CALL-ing an F90-style subroutine with an INTERFACE
4308 block). That implies the expression evaluator will have to
4309 recognize the need for its own temporary anyway, meaning it'll
4310 construct a block within the one constructed here. */
4311
4312 ffecom_prepare_expr (expr);
4313
4314 ffecom_prepare_end ();
4315
4316 if (labels == NULL)
4317 expand_expr_stmt (ffecom_expr (expr));
4318 else
4319 {
4320 tree texpr;
4321 tree value;
4322 tree tlabel;
4323 int caseno;
4324 int pushok;
4325 tree duplicate;
4326 ffebld label;
4327
4328 texpr = ffecom_expr (expr);
4329 expand_start_case (0, texpr, TREE_TYPE (texpr), "CALL statement");
4330
4331 for (caseno = 1, label = labels;
4332 label != NULL;
4333 ++caseno, label = ffebld_trail (label))
4334 {
4335 value = build_int_2 (caseno, 0);
4336 tlabel = build_decl (LABEL_DECL, NULL_TREE, NULL_TREE);
4337
4338 pushok = pushcase (value, convert, tlabel, &duplicate);
4339 assert (pushok == 0);
4340
4341 tlabel
4342 = ffecom_lookup_label (ffebld_labter (ffebld_head (label)));
4343 if ((tlabel == NULL_TREE)
4344 || (TREE_CODE (tlabel) == ERROR_MARK))
4345 continue;
4346 TREE_USED (tlabel) = 1;
4347 expand_goto (tlabel);
4348 }
4349
4350 expand_end_case (texpr);
4351 }
4352
4353 ffeste_end_stmt_ ();
4354 }
4355
4356 /* END FUNCTION. */
4357
4358 void
4359 ffeste_R1221 ()
4360 {
4361 }
4362
4363 /* END SUBROUTINE. */
4364
4365 void
4366 ffeste_R1225 ()
4367 {
4368 }
4369
4370 /* ENTRY statement. */
4371
4372 void
4373 ffeste_R1226 (ffesymbol entry)
4374 {
4375 tree label;
4376
4377 ffeste_check_simple_ ();
4378
4379 label = ffesymbol_hook (entry).length_tree;
4380
4381 ffeste_emit_line_note_ ();
4382
4383 if (label == error_mark_node)
4384 return;
4385
4386 DECL_INITIAL (label) = error_mark_node;
4387 emit_nop ();
4388 expand_label (label);
4389 }
4390
4391 /* RETURN statement. */
4392
4393 void
4394 ffeste_R1227 (ffestw block UNUSED, ffebld expr)
4395 {
4396 tree rtn;
4397
4398 ffeste_check_simple_ ();
4399
4400 ffeste_emit_line_note_ ();
4401
4402 ffeste_start_stmt_ ();
4403
4404 ffecom_prepare_return_expr (expr);
4405
4406 ffecom_prepare_end ();
4407
4408 rtn = ffecom_return_expr (expr);
4409
4410 if ((rtn == NULL_TREE)
4411 || (rtn == error_mark_node))
4412 expand_null_return ();
4413 else
4414 {
4415 tree result = DECL_RESULT (current_function_decl);
4416
4417 if ((result != error_mark_node)
4418 && (TREE_TYPE (result) != error_mark_node))
4419 expand_return (ffecom_modify (NULL_TREE,
4420 result,
4421 convert (TREE_TYPE (result),
4422 rtn)));
4423 else
4424 expand_null_return ();
4425 }
4426
4427 ffeste_end_stmt_ ();
4428 }
4429
4430 /* REWRITE statement -- start. */
4431
4432 #if FFESTR_VXT
4433 void
4434 ffeste_V018_start (ffestpRewriteStmt *info, ffestvFormat format)
4435 {
4436 ffeste_check_start_ ();
4437 }
4438
4439 /* REWRITE statement -- I/O item. */
4440
4441 void
4442 ffeste_V018_item (ffebld expr)
4443 {
4444 ffeste_check_item_ ();
4445 }
4446
4447 /* REWRITE statement -- end. */
4448
4449 void
4450 ffeste_V018_finish ()
4451 {
4452 ffeste_check_finish_ ();
4453 }
4454
4455 /* ACCEPT statement -- start. */
4456
4457 void
4458 ffeste_V019_start (ffestpAcceptStmt *info, ffestvFormat format)
4459 {
4460 ffeste_check_start_ ();
4461 }
4462
4463 /* ACCEPT statement -- I/O item. */
4464
4465 void
4466 ffeste_V019_item (ffebld expr)
4467 {
4468 ffeste_check_item_ ();
4469 }
4470
4471 /* ACCEPT statement -- end. */
4472
4473 void
4474 ffeste_V019_finish ()
4475 {
4476 ffeste_check_finish_ ();
4477 }
4478
4479 #endif
4480 /* TYPE statement -- start. */
4481
4482 void
4483 ffeste_V020_start (ffestpTypeStmt *info UNUSED,
4484 ffestvFormat format UNUSED)
4485 {
4486 ffeste_check_start_ ();
4487 }
4488
4489 /* TYPE statement -- I/O item. */
4490
4491 void
4492 ffeste_V020_item (ffebld expr UNUSED)
4493 {
4494 ffeste_check_item_ ();
4495 }
4496
4497 /* TYPE statement -- end. */
4498
4499 void
4500 ffeste_V020_finish ()
4501 {
4502 ffeste_check_finish_ ();
4503 }
4504
4505 /* DELETE statement. */
4506
4507 #if FFESTR_VXT
4508 void
4509 ffeste_V021 (ffestpDeleteStmt *info)
4510 {
4511 ffeste_check_simple_ ();
4512 }
4513
4514 /* UNLOCK statement. */
4515
4516 void
4517 ffeste_V022 (ffestpBeruStmt *info)
4518 {
4519 ffeste_check_simple_ ();
4520 }
4521
4522 /* ENCODE statement -- start. */
4523
4524 void
4525 ffeste_V023_start (ffestpVxtcodeStmt *info)
4526 {
4527 ffeste_check_start_ ();
4528 }
4529
4530 /* ENCODE statement -- I/O item. */
4531
4532 void
4533 ffeste_V023_item (ffebld expr)
4534 {
4535 ffeste_check_item_ ();
4536 }
4537
4538 /* ENCODE statement -- end. */
4539
4540 void
4541 ffeste_V023_finish ()
4542 {
4543 ffeste_check_finish_ ();
4544 }
4545
4546 /* DECODE statement -- start. */
4547
4548 void
4549 ffeste_V024_start (ffestpVxtcodeStmt *info)
4550 {
4551 ffeste_check_start_ ();
4552 }
4553
4554 /* DECODE statement -- I/O item. */
4555
4556 void
4557 ffeste_V024_item (ffebld expr)
4558 {
4559 ffeste_check_item_ ();
4560 }
4561
4562 /* DECODE statement -- end. */
4563
4564 void
4565 ffeste_V024_finish ()
4566 {
4567 ffeste_check_finish_ ();
4568 }
4569
4570 /* DEFINEFILE statement -- start. */
4571
4572 void
4573 ffeste_V025_start ()
4574 {
4575 ffeste_check_start_ ();
4576 }
4577
4578 /* DEFINE FILE statement -- item. */
4579
4580 void
4581 ffeste_V025_item (ffebld u, ffebld m, ffebld n, ffebld asv)
4582 {
4583 ffeste_check_item_ ();
4584 }
4585
4586 /* DEFINE FILE statement -- end. */
4587
4588 void
4589 ffeste_V025_finish ()
4590 {
4591 ffeste_check_finish_ ();
4592 }
4593
4594 /* FIND statement. */
4595
4596 void
4597 ffeste_V026 (ffestpFindStmt *info)
4598 {
4599 ffeste_check_simple_ ();
4600 }
4601
4602 #endif
4603
4604 #ifdef ENABLE_CHECKING
4605 void
4606 ffeste_terminate_2 (void)
4607 {
4608 assert (! ffeste_top_block_);
4609 }
4610 #endif
4611
4612 #include "gt-f-ste.h"
Mirror of the offical gcc git repository hosted at gcc.gnu.org