]> git.ipfire.org Git - thirdparty/gcc.git/blob - gcc/f/ste.c
projects / thirdparty / gcc.git / blob
? search:


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