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