?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
* gcc.c (option_map): Remove --version.
[official-gcc.git] / gcc / f / ste.c
blob6d1d0dc46dc8226569cc400597f0f7e1da79fe9f
1 /* ste.c -- Implementation File (module.c template V1.0)
2 Copyright (C) 1995, 1996, 2000 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_if_false (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 ffebad_start_msg ("SELECT CASE on CHARACTER type (at %0) not supported -- sorry",
2636 FFEBAD_severityFATAL);
2637 ffebad_here (0, ffestw_line (block), ffestw_col (block));
2638 ffebad_finish ();
2639 ffestw_set_select_texpr (block, error_mark_node);
2640 }
2641 else
2642 {
2643 tree result;
2644 tree texpr;
2645
2646 result = ffecom_make_tempvar ("select", ffecom_type_expr (expr),
2647 ffeinfo_size (ffebld_info (expr)),
2648 -1);
2649
2650 ffeste_start_stmt_ ();
2651
2652 ffecom_prepare_expr (expr);
2653
2654 ffecom_prepare_end ();
2655
2656 texpr = ffecom_expr (expr);
2657
2658 assert (TYPE_MAIN_VARIANT (TREE_TYPE (texpr))
2659 == TYPE_MAIN_VARIANT (TREE_TYPE (result)));
2660
2661 texpr = ffecom_modify (void_type_node,
2662 result,
2663 texpr);
2664 expand_expr_stmt (texpr);
2665
2666 ffeste_end_stmt_ ();
2667
2668 expand_start_case (1, result, TREE_TYPE (result),
2669 "SELECT CASE statement");
2670 ffestw_set_select_texpr (block, texpr);
2671 ffestw_set_select_break (block, FALSE);
2672 }
2673 }
2674
2675 /* CASE statement.
2676
2677 If casenum is 0, it's CASE DEFAULT. Else it's the case ranges at
2678 the start of the first_stmt list in the select object at the top of
2679 the stack that match casenum. */
2680
2681 void
2682 ffeste_R810 (ffestw block, unsigned long casenum)
2683 {
2684 ffestwSelect s = ffestw_select (block);
2685 ffestwCase c;
2686 tree texprlow;
2687 tree texprhigh;
2688 tree tlabel;
2689 int pushok;
2690 tree duplicate;
2691
2692 ffeste_check_simple_ ();
2693
2694 if (s->first_stmt == (ffestwCase) &s->first_rel)
2695 c = NULL;
2696 else
2697 c = s->first_stmt;
2698
2699 ffeste_emit_line_note_ ();
2700
2701 if (ffestw_select_texpr (block) == error_mark_node)
2702 return;
2703
2704 /* ~~~Someday handle CHARACTER*1, CHARACTER*N */
2705
2706 tlabel = build_decl (LABEL_DECL, NULL_TREE, NULL_TREE);
2707
2708 if (ffestw_select_break (block))
2709 expand_exit_something ();
2710 else
2711 ffestw_set_select_break (block, TRUE);
2712
2713 if ((c == NULL) || (casenum != c->casenum))
2714 {
2715 if (casenum == 0) /* Intentional CASE DEFAULT. */
2716 {
2717 pushok = pushcase (NULL_TREE, 0, tlabel, &duplicate);
2718 assert (pushok == 0);
2719 }
2720 }
2721 else
2722 do
2723 {
2724 texprlow = (c->low == NULL) ? NULL_TREE
2725 : ffecom_constantunion (&ffebld_constant_union (c->low), s->type,
2726 s->kindtype,
2727 ffecom_tree_type[s->type][s->kindtype]);
2728 if (c->low != c->high)
2729 {
2730 texprhigh = (c->high == NULL) ? NULL_TREE
2731 : ffecom_constantunion (&ffebld_constant_union (c->high),
2732 s->type, s->kindtype,
2733 ffecom_tree_type[s->type][s->kindtype]);
2734 pushok = pushcase_range (texprlow, texprhigh, convert,
2735 tlabel, &duplicate);
2736 }
2737 else
2738 pushok = pushcase (texprlow, convert, tlabel, &duplicate);
2739 assert (pushok == 0);
2740 c = c->next_stmt;
2741 /* Unlink prev. */
2742 c->previous_stmt->previous_stmt->next_stmt = c;
2743 c->previous_stmt = c->previous_stmt->previous_stmt;
2744 }
2745 while ((c != (ffestwCase) &s->first_rel) && (casenum == c->casenum));
2746 }
2747
2748 /* END SELECT statement. */
2749
2750 void
2751 ffeste_R811 (ffestw block)
2752 {
2753 ffeste_emit_line_note_ ();
2754
2755 /* ~~~Someday handle CHARACTER*1, CHARACTER*N */
2756
2757 if (TREE_CODE (ffestw_select_texpr (block)) != ERROR_MARK)
2758 expand_end_case (ffestw_select_texpr (block));
2759
2760 ffeste_end_block_ (block);
2761 }
2762
2763 /* Iterative DO statement. */
2764
2765 void
2766 ffeste_R819A (ffestw block, ffelab label UNUSED, ffebld var,
2767 ffebld start, ffelexToken start_token,
2768 ffebld end, ffelexToken end_token,
2769 ffebld incr, ffelexToken incr_token)
2770 {
2771 ffeste_check_simple_ ();
2772
2773 ffeste_emit_line_note_ ();
2774
2775 ffeste_begin_iterdo_ (block, NULL, NULL, NULL,
2776 var,
2777 start, start_token,
2778 end, end_token,
2779 incr, incr_token,
2780 "Iterative DO loop");
2781 }
2782
2783 /* DO WHILE statement. */
2784
2785 void
2786 ffeste_R819B (ffestw block, ffelab label UNUSED, ffebld expr)
2787 {
2788 tree result;
2789
2790 ffeste_check_simple_ ();
2791
2792 ffeste_emit_line_note_ ();
2793
2794 ffeste_start_block_ (block);
2795
2796 if (expr)
2797 {
2798 struct nesting *loop;
2799 tree mod;
2800
2801 result = ffecom_make_tempvar ("dowhile", integer_type_node,
2802 FFETARGET_charactersizeNONE, -1);
2803 loop = expand_start_loop (1);
2804
2805 ffeste_start_stmt_ ();
2806
2807 ffecom_prepare_expr (expr);
2808
2809 ffecom_prepare_end ();
2810
2811 mod = ffecom_modify (void_type_node,
2812 result,
2813 ffecom_truth_value (ffecom_expr (expr)));
2814 expand_expr_stmt (mod);
2815
2816 ffeste_end_stmt_ ();
2817
2818 ffestw_set_do_hook (block, loop);
2819 expand_exit_loop_if_false (0, result);
2820 }
2821 else
2822 ffestw_set_do_hook (block, expand_start_loop (1));
2823
2824 ffestw_set_do_tvar (block, NULL_TREE);
2825 }
2826
2827 /* END DO statement.
2828
2829 This is the MIL-STD 1753 END DO. It's syntactic sugar, similar to
2830 CONTINUE (except that it has to have a label that is the target of
2831 one or more iterative DO statement), not the Fortran-90 structured
2832 END DO, which is handled elsewhere, as is the actual mechanism of
2833 ending an iterative DO statement, even one that ends at a label. */
2834
2835 void
2836 ffeste_R825 ()
2837 {
2838 ffeste_check_simple_ ();
2839
2840 ffeste_emit_line_note_ ();
2841
2842 emit_nop ();
2843 }
2844
2845 /* CYCLE statement. */
2846
2847 void
2848 ffeste_R834 (ffestw block)
2849 {
2850 ffeste_check_simple_ ();
2851
2852 ffeste_emit_line_note_ ();
2853
2854 expand_continue_loop (ffestw_do_hook (block));
2855 }
2856
2857 /* EXIT statement. */
2858
2859 void
2860 ffeste_R835 (ffestw block)
2861 {
2862 ffeste_check_simple_ ();
2863
2864 ffeste_emit_line_note_ ();
2865
2866 expand_exit_loop (ffestw_do_hook (block));
2867 }
2868
2869 /* GOTO statement. */
2870
2871 void
2872 ffeste_R836 (ffelab label)
2873 {
2874 tree glabel;
2875
2876 ffeste_check_simple_ ();
2877
2878 ffeste_emit_line_note_ ();
2879
2880 glabel = ffecom_lookup_label (label);
2881 if ((glabel != NULL_TREE)
2882 && (TREE_CODE (glabel) != ERROR_MARK))
2883 {
2884 expand_goto (glabel);
2885 TREE_USED (glabel) = 1;
2886 }
2887 }
2888
2889 /* Computed GOTO statement. */
2890
2891 void
2892 ffeste_R837 (ffelab *labels, int count, ffebld expr)
2893 {
2894 int i;
2895 tree texpr;
2896 tree value;
2897 tree tlabel;
2898 int pushok;
2899 tree duplicate;
2900
2901 ffeste_check_simple_ ();
2902
2903 ffeste_emit_line_note_ ();
2904
2905 ffeste_start_stmt_ ();
2906
2907 ffecom_prepare_expr (expr);
2908
2909 ffecom_prepare_end ();
2910
2911 texpr = ffecom_expr (expr);
2912
2913 expand_start_case (0, texpr, TREE_TYPE (texpr), "computed GOTO statement");
2914
2915 for (i = 0; i < count; ++i)
2916 {
2917 value = build_int_2 (i + 1, 0);
2918 tlabel = build_decl (LABEL_DECL, NULL_TREE, NULL_TREE);
2919
2920 pushok = pushcase (value, convert, tlabel, &duplicate);
2921 assert (pushok == 0);
2922
2923 tlabel = ffecom_lookup_label (labels[i]);
2924 if ((tlabel == NULL_TREE)
2925 || (TREE_CODE (tlabel) == ERROR_MARK))
2926 continue;
2927
2928 expand_goto (tlabel);
2929 TREE_USED (tlabel) = 1;
2930 }
2931 expand_end_case (texpr);
2932
2933 ffeste_end_stmt_ ();
2934 }
2935
2936 /* ASSIGN statement. */
2937
2938 void
2939 ffeste_R838 (ffelab label, ffebld target)
2940 {
2941 tree expr_tree;
2942 tree label_tree;
2943 tree target_tree;
2944
2945 ffeste_check_simple_ ();
2946
2947 ffeste_emit_line_note_ ();
2948
2949 /* No need to call ffeste_start_stmt_(), as the sorts of expressions
2950 seen here should never require use of temporaries. */
2951
2952 label_tree = ffecom_lookup_label (label);
2953 if ((label_tree != NULL_TREE)
2954 && (TREE_CODE (label_tree) != ERROR_MARK))
2955 {
2956 label_tree = ffecom_1 (ADDR_EXPR,
2957 build_pointer_type (void_type_node),
2958 label_tree);
2959 TREE_CONSTANT (label_tree) = 1;
2960
2961 target_tree = ffecom_expr_assign_w (target);
2962 if (GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (target_tree)))
2963 < GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (label_tree))))
2964 error ("ASSIGN to variable that is too small");
2965
2966 label_tree = convert (TREE_TYPE (target_tree), label_tree);
2967
2968 expr_tree = ffecom_modify (void_type_node,
2969 target_tree,
2970 label_tree);
2971 expand_expr_stmt (expr_tree);
2972 }
2973 }
2974
2975 /* Assigned GOTO statement. */
2976
2977 void
2978 ffeste_R839 (ffebld target)
2979 {
2980 tree t;
2981
2982 ffeste_check_simple_ ();
2983
2984 ffeste_emit_line_note_ ();
2985
2986 /* No need to call ffeste_start_stmt_(), as the sorts of expressions
2987 seen here should never require use of temporaries. */
2988
2989 t = ffecom_expr_assign (target);
2990 if (GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (t)))
2991 < GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node))))
2992 error ("ASSIGNed GOTO target variable is too small");
2993
2994 expand_computed_goto (convert (TREE_TYPE (null_pointer_node), t));
2995 }
2996
2997 /* Arithmetic IF statement. */
2998
2999 void
3000 ffeste_R840 (ffebld expr, ffelab neg, ffelab zero, ffelab pos)
3001 {
3002 tree gneg = ffecom_lookup_label (neg);
3003 tree gzero = ffecom_lookup_label (zero);
3004 tree gpos = ffecom_lookup_label (pos);
3005 tree texpr;
3006
3007 ffeste_check_simple_ ();
3008
3009 ffeste_emit_line_note_ ();
3010
3011 if ((gneg == NULL_TREE) || (gzero == NULL_TREE) || (gpos == NULL_TREE))
3012 return;
3013 if ((TREE_CODE (gneg) == ERROR_MARK)
3014 || (TREE_CODE (gzero) == ERROR_MARK)
3015 || (TREE_CODE (gpos) == ERROR_MARK))
3016 return;
3017
3018 ffeste_start_stmt_ ();
3019
3020 ffecom_prepare_expr (expr);
3021
3022 ffecom_prepare_end ();
3023
3024 if (neg == zero)
3025 {
3026 if (neg == pos)
3027 expand_goto (gzero);
3028 else
3029 {
3030 /* IF (expr.LE.0) THEN GOTO neg/zero ELSE GOTO pos. */
3031 texpr = ffecom_expr (expr);
3032 texpr = ffecom_2 (LE_EXPR, integer_type_node,
3033 texpr,
3034 convert (TREE_TYPE (texpr),
3035 integer_zero_node));
3036 expand_start_cond (ffecom_truth_value (texpr), 0);
3037 expand_goto (gzero);
3038 expand_start_else ();
3039 expand_goto (gpos);
3040 expand_end_cond ();
3041 }
3042 }
3043 else if (neg == pos)
3044 {
3045 /* IF (expr.NE.0) THEN GOTO neg/pos ELSE GOTO zero. */
3046 texpr = ffecom_expr (expr);
3047 texpr = ffecom_2 (NE_EXPR, integer_type_node,
3048 texpr,
3049 convert (TREE_TYPE (texpr),
3050 integer_zero_node));
3051 expand_start_cond (ffecom_truth_value (texpr), 0);
3052 expand_goto (gneg);
3053 expand_start_else ();
3054 expand_goto (gzero);
3055 expand_end_cond ();
3056 }
3057 else if (zero == pos)
3058 {
3059 /* IF (expr.GE.0) THEN GOTO zero/pos ELSE GOTO neg. */
3060 texpr = ffecom_expr (expr);
3061 texpr = ffecom_2 (GE_EXPR, integer_type_node,
3062 texpr,
3063 convert (TREE_TYPE (texpr),
3064 integer_zero_node));
3065 expand_start_cond (ffecom_truth_value (texpr), 0);
3066 expand_goto (gzero);
3067 expand_start_else ();
3068 expand_goto (gneg);
3069 expand_end_cond ();
3070 }
3071 else
3072 {
3073 /* Use a SAVE_EXPR in combo with:
3074 IF (expr.LT.0) THEN GOTO neg
3075 ELSEIF (expr.GT.0) THEN GOTO pos
3076 ELSE GOTO zero. */
3077 tree expr_saved = ffecom_save_tree (ffecom_expr (expr));
3078
3079 texpr = ffecom_2 (LT_EXPR, integer_type_node,
3080 expr_saved,
3081 convert (TREE_TYPE (expr_saved),
3082 integer_zero_node));
3083 expand_start_cond (ffecom_truth_value (texpr), 0);
3084 expand_goto (gneg);
3085 texpr = ffecom_2 (GT_EXPR, integer_type_node,
3086 expr_saved,
3087 convert (TREE_TYPE (expr_saved),
3088 integer_zero_node));
3089 expand_start_elseif (ffecom_truth_value (texpr));
3090 expand_goto (gpos);
3091 expand_start_else ();
3092 expand_goto (gzero);
3093 expand_end_cond ();
3094 }
3095
3096 ffeste_end_stmt_ ();
3097 }
3098
3099 /* CONTINUE statement. */
3100
3101 void
3102 ffeste_R841 ()
3103 {
3104 ffeste_check_simple_ ();
3105
3106 ffeste_emit_line_note_ ();
3107
3108 emit_nop ();
3109 }
3110
3111 /* STOP statement. */
3112
3113 void
3114 ffeste_R842 (ffebld expr)
3115 {
3116 tree callit;
3117 ffelexToken msg;
3118
3119 ffeste_check_simple_ ();
3120
3121 ffeste_emit_line_note_ ();
3122
3123 if ((expr == NULL)
3124 || (ffeinfo_basictype (ffebld_info (expr))
3125 == FFEINFO_basictypeANY))
3126 {
3127 msg = ffelex_token_new_character ("",
3128 ffelex_token_where_line (ffesta_tokens[0]),
3129 ffelex_token_where_column (ffesta_tokens[0]));
3130 expr = ffebld_new_conter (ffebld_constant_new_characterdefault
3131 (msg));
3132 ffelex_token_kill (msg);
3133 ffebld_set_info (expr, ffeinfo_new (FFEINFO_basictypeCHARACTER,
3134 FFEINFO_kindtypeCHARACTERDEFAULT,
3135 0, FFEINFO_kindENTITY,
3136 FFEINFO_whereCONSTANT, 0));
3137 }
3138 else if (ffeinfo_basictype (ffebld_info (expr))
3139 == FFEINFO_basictypeINTEGER)
3140 {
3141 char num[50];
3142
3143 assert (ffebld_op (expr) == FFEBLD_opCONTER);
3144 assert (ffeinfo_kindtype (ffebld_info (expr))
3145 == FFEINFO_kindtypeINTEGERDEFAULT);
3146 sprintf (num, "%" ffetargetIntegerDefault_f "d",
3147 ffebld_constant_integer1 (ffebld_conter (expr)));
3148 msg = ffelex_token_new_character (num,
3149 ffelex_token_where_line (ffesta_tokens[0]),
3150 ffelex_token_where_column (ffesta_tokens[0]));
3151 expr = ffebld_new_conter (ffebld_constant_new_characterdefault (msg));
3152 ffelex_token_kill (msg);
3153 ffebld_set_info (expr, ffeinfo_new (FFEINFO_basictypeCHARACTER,
3154 FFEINFO_kindtypeCHARACTERDEFAULT,
3155 0, FFEINFO_kindENTITY,
3156 FFEINFO_whereCONSTANT, 0));
3157 }
3158 else
3159 {
3160 assert (ffeinfo_basictype (ffebld_info (expr))
3161 == FFEINFO_basictypeCHARACTER);
3162 assert (ffebld_op (expr) == FFEBLD_opCONTER);
3163 assert (ffeinfo_kindtype (ffebld_info (expr))
3164 == FFEINFO_kindtypeCHARACTERDEFAULT);
3165 }
3166
3167 /* No need to call ffeste_start_stmt_(), as the sorts of expressions
3168 seen here should never require use of temporaries. */
3169
3170 callit = ffecom_call_gfrt (FFECOM_gfrtSTOP,
3171 ffecom_list_ptr_to_expr (ffebld_new_item (expr, NULL)),
3172 NULL_TREE);
3173 TREE_SIDE_EFFECTS (callit) = 1;
3174
3175 expand_expr_stmt (callit);
3176 }
3177
3178 /* PAUSE statement. */
3179
3180 void
3181 ffeste_R843 (ffebld expr)
3182 {
3183 tree callit;
3184 ffelexToken msg;
3185
3186 ffeste_check_simple_ ();
3187
3188 ffeste_emit_line_note_ ();
3189
3190 if ((expr == NULL)
3191 || (ffeinfo_basictype (ffebld_info (expr))
3192 == FFEINFO_basictypeANY))
3193 {
3194 msg = ffelex_token_new_character ("",
3195 ffelex_token_where_line (ffesta_tokens[0]),
3196 ffelex_token_where_column (ffesta_tokens[0]));
3197 expr = ffebld_new_conter (ffebld_constant_new_characterdefault (msg));
3198 ffelex_token_kill (msg);
3199 ffebld_set_info (expr, ffeinfo_new (FFEINFO_basictypeCHARACTER,
3200 FFEINFO_kindtypeCHARACTERDEFAULT,
3201 0, FFEINFO_kindENTITY,
3202 FFEINFO_whereCONSTANT, 0));
3203 }
3204 else if (ffeinfo_basictype (ffebld_info (expr)) == FFEINFO_basictypeINTEGER)
3205 {
3206 char num[50];
3207
3208 assert (ffebld_op (expr) == FFEBLD_opCONTER);
3209 assert (ffeinfo_kindtype (ffebld_info (expr))
3210 == FFEINFO_kindtypeINTEGERDEFAULT);
3211 sprintf (num, "%" ffetargetIntegerDefault_f "d",
3212 ffebld_constant_integer1 (ffebld_conter (expr)));
3213 msg = ffelex_token_new_character (num, ffelex_token_where_line (ffesta_tokens[0]),
3214 ffelex_token_where_column (ffesta_tokens[0]));
3215 expr = ffebld_new_conter (ffebld_constant_new_characterdefault (msg));
3216 ffelex_token_kill (msg);
3217 ffebld_set_info (expr, ffeinfo_new (FFEINFO_basictypeCHARACTER,
3218 FFEINFO_kindtypeCHARACTERDEFAULT,
3219 0, FFEINFO_kindENTITY,
3220 FFEINFO_whereCONSTANT, 0));
3221 }
3222 else
3223 {
3224 assert (ffeinfo_basictype (ffebld_info (expr))
3225 == FFEINFO_basictypeCHARACTER);
3226 assert (ffebld_op (expr) == FFEBLD_opCONTER);
3227 assert (ffeinfo_kindtype (ffebld_info (expr))
3228 == FFEINFO_kindtypeCHARACTERDEFAULT);
3229 }
3230
3231 /* No need to call ffeste_start_stmt_(), as the sorts of expressions
3232 seen here should never require use of temporaries. */
3233
3234 callit = ffecom_call_gfrt (FFECOM_gfrtPAUSE,
3235 ffecom_list_ptr_to_expr (ffebld_new_item (expr, NULL)),
3236 NULL_TREE);
3237 TREE_SIDE_EFFECTS (callit) = 1;
3238
3239 expand_expr_stmt (callit);
3240 }
3241
3242 /* OPEN statement. */
3243
3244 void
3245 ffeste_R904 (ffestpOpenStmt *info)
3246 {
3247 tree args;
3248 bool iostat;
3249 bool errl;
3250
3251 ffeste_check_simple_ ();
3252
3253 ffeste_emit_line_note_ ();
3254
3255 #define specified(something) (info->open_spec[something].kw_or_val_present)
3256
3257 iostat = specified (FFESTP_openixIOSTAT);
3258 errl = specified (FFESTP_openixERR);
3259
3260 #undef specified
3261
3262 ffeste_start_stmt_ ();
3263
3264 if (errl)
3265 {
3266 ffeste_io_err_
3267 = ffeste_io_abort_
3268 = ffecom_lookup_label
3269 (info->open_spec[FFESTP_openixERR].u.label);
3270 ffeste_io_abort_is_temp_ = FALSE;
3271 }
3272 else
3273 {
3274 ffeste_io_err_ = NULL_TREE;
3275
3276 if ((ffeste_io_abort_is_temp_ = iostat))
3277 ffeste_io_abort_ = ffecom_temp_label ();
3278 else
3279 ffeste_io_abort_ = NULL_TREE;
3280 }
3281
3282 if (iostat)
3283 {
3284 /* Have IOSTAT= specification. */
3285
3286 ffeste_io_iostat_is_temp_ = FALSE;
3287 ffeste_io_iostat_ = ffecom_expr
3288 (info->open_spec[FFESTP_openixIOSTAT].u.expr);
3289 }
3290 else if (ffeste_io_abort_ != NULL_TREE)
3291 {
3292 /* Have no IOSTAT= but have ERR=. */
3293
3294 ffeste_io_iostat_is_temp_ = TRUE;
3295 ffeste_io_iostat_
3296 = ffecom_make_tempvar ("open", ffecom_integer_type_node,
3297 FFETARGET_charactersizeNONE, -1);
3298 }
3299 else
3300 {
3301 /* No IOSTAT= or ERR= specification. */
3302
3303 ffeste_io_iostat_is_temp_ = FALSE;
3304 ffeste_io_iostat_ = NULL_TREE;
3305 }
3306
3307 /* Now prescan, then convert, all the arguments. */
3308
3309 args = ffeste_io_olist_ (errl || iostat,
3310 info->open_spec[FFESTP_openixUNIT].u.expr,
3311 &info->open_spec[FFESTP_openixFILE],
3312 &info->open_spec[FFESTP_openixSTATUS],
3313 &info->open_spec[FFESTP_openixACCESS],
3314 &info->open_spec[FFESTP_openixFORM],
3315 &info->open_spec[FFESTP_openixRECL],
3316 &info->open_spec[FFESTP_openixBLANK]);
3317
3318 /* Don't generate "if (iostat != 0) goto label;" if label is temp abort
3319 label, since we're gonna fall through to there anyway. */
3320
3321 ffeste_io_call_ (ffecom_call_gfrt (FFECOM_gfrtFOPEN, args, NULL_TREE),
3322 ! ffeste_io_abort_is_temp_);
3323
3324 /* If we've got a temp label, generate its code here. */
3325
3326 if (ffeste_io_abort_is_temp_)
3327 {
3328 DECL_INITIAL (ffeste_io_abort_) = error_mark_node;
3329 emit_nop ();
3330 expand_label (ffeste_io_abort_);
3331
3332 assert (ffeste_io_err_ == NULL_TREE);
3333 }
3334
3335 ffeste_end_stmt_ ();
3336 }
3337
3338 /* CLOSE statement. */
3339
3340 void
3341 ffeste_R907 (ffestpCloseStmt *info)
3342 {
3343 tree args;
3344 bool iostat;
3345 bool errl;
3346
3347 ffeste_check_simple_ ();
3348
3349 ffeste_emit_line_note_ ();
3350
3351 #define specified(something) (info->close_spec[something].kw_or_val_present)
3352
3353 iostat = specified (FFESTP_closeixIOSTAT);
3354 errl = specified (FFESTP_closeixERR);
3355
3356 #undef specified
3357
3358 ffeste_start_stmt_ ();
3359
3360 if (errl)
3361 {
3362 ffeste_io_err_
3363 = ffeste_io_abort_
3364 = ffecom_lookup_label
3365 (info->close_spec[FFESTP_closeixERR].u.label);
3366 ffeste_io_abort_is_temp_ = FALSE;
3367 }
3368 else
3369 {
3370 ffeste_io_err_ = NULL_TREE;
3371
3372 if ((ffeste_io_abort_is_temp_ = iostat))
3373 ffeste_io_abort_ = ffecom_temp_label ();
3374 else
3375 ffeste_io_abort_ = NULL_TREE;
3376 }
3377
3378 if (iostat)
3379 {
3380 /* Have IOSTAT= specification. */
3381
3382 ffeste_io_iostat_is_temp_ = FALSE;
3383 ffeste_io_iostat_ = ffecom_expr
3384 (info->close_spec[FFESTP_closeixIOSTAT].u.expr);
3385 }
3386 else if (ffeste_io_abort_ != NULL_TREE)
3387 {
3388 /* Have no IOSTAT= but have ERR=. */
3389
3390 ffeste_io_iostat_is_temp_ = TRUE;
3391 ffeste_io_iostat_
3392 = ffecom_make_tempvar ("close", ffecom_integer_type_node,
3393 FFETARGET_charactersizeNONE, -1);
3394 }
3395 else
3396 {
3397 /* No IOSTAT= or ERR= specification. */
3398
3399 ffeste_io_iostat_is_temp_ = FALSE;
3400 ffeste_io_iostat_ = NULL_TREE;
3401 }
3402
3403 /* Now prescan, then convert, all the arguments. */
3404
3405 args = ffeste_io_cllist_ (errl || iostat,
3406 info->close_spec[FFESTP_closeixUNIT].u.expr,
3407 &info->close_spec[FFESTP_closeixSTATUS]);
3408
3409 /* Don't generate "if (iostat != 0) goto label;" if label is temp abort
3410 label, since we're gonna fall through to there anyway. */
3411
3412 ffeste_io_call_ (ffecom_call_gfrt (FFECOM_gfrtFCLOS, args, NULL_TREE),
3413 ! ffeste_io_abort_is_temp_);
3414
3415 /* If we've got a temp label, generate its code here. */
3416
3417 if (ffeste_io_abort_is_temp_)
3418 {
3419 DECL_INITIAL (ffeste_io_abort_) = error_mark_node;
3420 emit_nop ();
3421 expand_label (ffeste_io_abort_);
3422
3423 assert (ffeste_io_err_ == NULL_TREE);
3424 }
3425
3426 ffeste_end_stmt_ ();
3427 }
3428
3429 /* READ(...) statement -- start. */
3430
3431 void
3432 ffeste_R909_start (ffestpReadStmt *info, bool only_format UNUSED,
3433 ffestvUnit unit, ffestvFormat format, bool rec,
3434 bool key UNUSED)
3435 {
3436 ffecomGfrt start;
3437 ffecomGfrt end;
3438 tree cilist;
3439 bool iostat;
3440 bool errl;
3441 bool endl;
3442
3443 ffeste_check_start_ ();
3444
3445 ffeste_emit_line_note_ ();
3446
3447 /* First determine the start, per-item, and end run-time functions to
3448 call. The per-item function is picked by choosing an ffeste function
3449 to call to handle a given item; it knows how to generate a call to the
3450 appropriate run-time function, and is called an "I/O driver". */
3451
3452 switch (format)
3453 {
3454 case FFESTV_formatNONE: /* no FMT= */
3455 ffeste_io_driver_ = ffeste_io_douio_;
3456 if (rec)
3457 start = FFECOM_gfrtSRDUE, end = FFECOM_gfrtERDUE;
3458 else
3459 start = FFECOM_gfrtSRSUE, end = FFECOM_gfrtERSUE;
3460 break;
3461
3462 case FFESTV_formatLABEL: /* FMT=10 */
3463 case FFESTV_formatCHAREXPR: /* FMT='(I10)' */
3464 case FFESTV_formatINTEXPR: /* FMT=I [after ASSIGN 10 TO I] */
3465 ffeste_io_driver_ = ffeste_io_dofio_;
3466 if (rec)
3467 start = FFECOM_gfrtSRDFE, end = FFECOM_gfrtERDFE;
3468 else if (unit == FFESTV_unitCHAREXPR)
3469 start = FFECOM_gfrtSRSFI, end = FFECOM_gfrtERSFI;
3470 else
3471 start = FFECOM_gfrtSRSFE, end = FFECOM_gfrtERSFE;
3472 break;
3473
3474 case FFESTV_formatASTERISK: /* FMT=* */
3475 ffeste_io_driver_ = ffeste_io_dolio_;
3476 if (unit == FFESTV_unitCHAREXPR)
3477 start = FFECOM_gfrtSRSLI, end = FFECOM_gfrtERSLI;
3478 else
3479 start = FFECOM_gfrtSRSLE, end = FFECOM_gfrtERSLE;
3480 break;
3481
3482 case FFESTV_formatNAMELIST: /* FMT=FOO or NML=FOO [NAMELIST
3483 /FOO/] */
3484 ffeste_io_driver_ = NULL; /* No start or driver function. */
3485 start = FFECOM_gfrtSRSNE, end = FFECOM_gfrt;
3486 break;
3487
3488 default:
3489 assert ("Weird stuff" == NULL);
3490 start = FFECOM_gfrt, end = FFECOM_gfrt;
3491 break;
3492 }
3493 ffeste_io_endgfrt_ = end;
3494
3495 #define specified(something) (info->read_spec[something].kw_or_val_present)
3496
3497 iostat = specified (FFESTP_readixIOSTAT);
3498 errl = specified (FFESTP_readixERR);
3499 endl = specified (FFESTP_readixEND);
3500
3501 #undef specified
3502
3503 ffeste_start_stmt_ ();
3504
3505 if (errl)
3506 {
3507 /* Have ERR= specification. */
3508
3509 ffeste_io_err_
3510 = ffecom_lookup_label (info->read_spec[FFESTP_readixERR].u.label);
3511
3512 if (endl)
3513 {
3514 /* Have both ERR= and END=. Need a temp label to handle both. */
3515 ffeste_io_end_
3516 = ffecom_lookup_label (info->read_spec[FFESTP_readixEND].u.label);
3517 ffeste_io_abort_is_temp_ = TRUE;
3518 ffeste_io_abort_ = ffecom_temp_label ();
3519 }
3520 else
3521 {
3522 /* Have ERR= but no END=. */
3523 ffeste_io_end_ = NULL_TREE;
3524 if ((ffeste_io_abort_is_temp_ = iostat))
3525 ffeste_io_abort_ = ffecom_temp_label ();
3526 else
3527 ffeste_io_abort_ = ffeste_io_err_;
3528 }
3529 }
3530 else
3531 {
3532 /* No ERR= specification. */
3533
3534 ffeste_io_err_ = NULL_TREE;
3535 if (endl)
3536 {
3537 /* Have END= but no ERR=. */
3538 ffeste_io_end_
3539 = ffecom_lookup_label (info->read_spec[FFESTP_readixEND].u.label);
3540 if ((ffeste_io_abort_is_temp_ = iostat))
3541 ffeste_io_abort_ = ffecom_temp_label ();
3542 else
3543 ffeste_io_abort_ = ffeste_io_end_;
3544 }
3545 else
3546 {
3547 /* Have no ERR= or END=. */
3548
3549 ffeste_io_end_ = NULL_TREE;
3550 if ((ffeste_io_abort_is_temp_ = iostat))
3551 ffeste_io_abort_ = ffecom_temp_label ();
3552 else
3553 ffeste_io_abort_ = NULL_TREE;
3554 }
3555 }
3556
3557 if (iostat)
3558 {
3559 /* Have IOSTAT= specification. */
3560
3561 ffeste_io_iostat_is_temp_ = FALSE;
3562 ffeste_io_iostat_
3563 = ffecom_expr (info->read_spec[FFESTP_readixIOSTAT].u.expr);
3564 }
3565 else if (ffeste_io_abort_ != NULL_TREE)
3566 {
3567 /* Have no IOSTAT= but have ERR= and/or END=. */
3568
3569 ffeste_io_iostat_is_temp_ = TRUE;
3570 ffeste_io_iostat_
3571 = ffecom_make_tempvar ("read", ffecom_integer_type_node,
3572 FFETARGET_charactersizeNONE, -1);
3573 }
3574 else
3575 {
3576 /* No IOSTAT=, ERR=, or END= specification. */
3577
3578 ffeste_io_iostat_is_temp_ = FALSE;
3579 ffeste_io_iostat_ = NULL_TREE;
3580 }
3581
3582 /* Now prescan, then convert, all the arguments. */
3583
3584 if (unit == FFESTV_unitCHAREXPR)
3585 cilist = ffeste_io_icilist_ (errl || iostat,
3586 info->read_spec[FFESTP_readixUNIT].u.expr,
3587 endl || iostat, format,
3588 &info->read_spec[FFESTP_readixFORMAT]);
3589 else
3590 cilist = ffeste_io_cilist_ (errl || iostat, unit,
3591 info->read_spec[FFESTP_readixUNIT].u.expr,
3592 5, endl || iostat, format,
3593 &info->read_spec[FFESTP_readixFORMAT],
3594 rec,
3595 info->read_spec[FFESTP_readixREC].u.expr);
3596
3597 /* If there is no end function, then there are no item functions (i.e.
3598 it's a NAMELIST), and vice versa by the way. In this situation, don't
3599 generate the "if (iostat != 0) goto label;" if the label is temp abort
3600 label, since we're gonna fall through to there anyway. */
3601
3602 ffeste_io_call_ (ffecom_call_gfrt (start, cilist, NULL_TREE),
3603 (! ffeste_io_abort_is_temp_) || (end != FFECOM_gfrt));
3604 }
3605
3606 /* READ statement -- I/O item. */
3607
3608 void
3609 ffeste_R909_item (ffebld expr, ffelexToken expr_token)
3610 {
3611 ffeste_check_item_ ();
3612
3613 if (expr == NULL)
3614 return;
3615
3616 /* Strip parens off items such as in "READ *,(A)". This is really a bug
3617 in the user's code, but I've been told lots of code does this. */
3618 while (ffebld_op (expr) == FFEBLD_opPAREN)
3619 expr = ffebld_left (expr);
3620
3621 if (ffebld_op (expr) == FFEBLD_opANY)
3622 return;
3623
3624 if (ffebld_op (expr) == FFEBLD_opIMPDO)
3625 ffeste_io_impdo_ (expr, expr_token);
3626 else
3627 {
3628 ffeste_start_stmt_ ();
3629
3630 ffecom_prepare_arg_ptr_to_expr (expr);
3631
3632 ffecom_prepare_end ();
3633
3634 ffeste_io_call_ ((*ffeste_io_driver_) (expr), TRUE);
3635
3636 ffeste_end_stmt_ ();
3637 }
3638 }
3639
3640 /* READ statement -- end. */
3641
3642 void
3643 ffeste_R909_finish ()
3644 {
3645 ffeste_check_finish_ ();
3646
3647 /* Don't generate "if (iostat != 0) goto label;" if label is temp abort
3648 label, since we're gonna fall through to there anyway. */
3649
3650 if (ffeste_io_endgfrt_ != FFECOM_gfrt)
3651 ffeste_io_call_ (ffecom_call_gfrt (ffeste_io_endgfrt_, NULL_TREE,
3652 NULL_TREE),
3653 ! ffeste_io_abort_is_temp_);
3654
3655 /* If we've got a temp label, generate its code here and have it fan out
3656 to the END= or ERR= label as appropriate. */
3657
3658 if (ffeste_io_abort_is_temp_)
3659 {
3660 DECL_INITIAL (ffeste_io_abort_) = error_mark_node;
3661 emit_nop ();
3662 expand_label (ffeste_io_abort_);
3663
3664 /* "if (iostat<0) goto end_label;". */
3665
3666 if ((ffeste_io_end_ != NULL_TREE)
3667 && (TREE_CODE (ffeste_io_end_) != ERROR_MARK))
3668 {
3669 expand_start_cond (ffecom_truth_value
3670 (ffecom_2 (LT_EXPR, integer_type_node,
3671 ffeste_io_iostat_,
3672 ffecom_integer_zero_node)),
3673 0);
3674 expand_goto (ffeste_io_end_);
3675 expand_end_cond ();
3676 }
3677
3678 /* "if (iostat>0) goto err_label;". */
3679
3680 if ((ffeste_io_err_ != NULL_TREE)
3681 && (TREE_CODE (ffeste_io_err_) != ERROR_MARK))
3682 {
3683 expand_start_cond (ffecom_truth_value
3684 (ffecom_2 (GT_EXPR, integer_type_node,
3685 ffeste_io_iostat_,
3686 ffecom_integer_zero_node)),
3687 0);
3688 expand_goto (ffeste_io_err_);
3689 expand_end_cond ();
3690 }
3691 }
3692
3693 ffeste_end_stmt_ ();
3694 }
3695
3696 /* WRITE statement -- start. */
3697
3698 void
3699 ffeste_R910_start (ffestpWriteStmt *info, ffestvUnit unit,
3700 ffestvFormat format, bool rec)
3701 {
3702 ffecomGfrt start;
3703 ffecomGfrt end;
3704 tree cilist;
3705 bool iostat;
3706 bool errl;
3707
3708 ffeste_check_start_ ();
3709
3710 ffeste_emit_line_note_ ();
3711
3712 /* First determine the start, per-item, and end run-time functions to
3713 call. The per-item function is picked by choosing an ffeste function
3714 to call to handle a given item; it knows how to generate a call to the
3715 appropriate run-time function, and is called an "I/O driver". */
3716
3717 switch (format)
3718 {
3719 case FFESTV_formatNONE: /* no FMT= */
3720 ffeste_io_driver_ = ffeste_io_douio_;
3721 if (rec)
3722 start = FFECOM_gfrtSWDUE, end = FFECOM_gfrtEWDUE;
3723 else
3724 start = FFECOM_gfrtSWSUE, end = FFECOM_gfrtEWSUE;
3725 break;
3726
3727 case FFESTV_formatLABEL: /* FMT=10 */
3728 case FFESTV_formatCHAREXPR: /* FMT='(I10)' */
3729 case FFESTV_formatINTEXPR: /* FMT=I [after ASSIGN 10 TO I] */
3730 ffeste_io_driver_ = ffeste_io_dofio_;
3731 if (rec)
3732 start = FFECOM_gfrtSWDFE, end = FFECOM_gfrtEWDFE;
3733 else if (unit == FFESTV_unitCHAREXPR)
3734 start = FFECOM_gfrtSWSFI, end = FFECOM_gfrtEWSFI;
3735 else
3736 start = FFECOM_gfrtSWSFE, end = FFECOM_gfrtEWSFE;
3737 break;
3738
3739 case FFESTV_formatASTERISK: /* FMT=* */
3740 ffeste_io_driver_ = ffeste_io_dolio_;
3741 if (unit == FFESTV_unitCHAREXPR)
3742 start = FFECOM_gfrtSWSLI, end = FFECOM_gfrtEWSLI;
3743 else
3744 start = FFECOM_gfrtSWSLE, end = FFECOM_gfrtEWSLE;
3745 break;
3746
3747 case FFESTV_formatNAMELIST: /* FMT=FOO or NML=FOO [NAMELIST
3748 /FOO/] */
3749 ffeste_io_driver_ = NULL; /* No start or driver function. */
3750 start = FFECOM_gfrtSWSNE, end = FFECOM_gfrt;
3751 break;
3752
3753 default:
3754 assert ("Weird stuff" == NULL);
3755 start = FFECOM_gfrt, end = FFECOM_gfrt;
3756 break;
3757 }
3758 ffeste_io_endgfrt_ = end;
3759
3760 #define specified(something) (info->write_spec[something].kw_or_val_present)
3761
3762 iostat = specified (FFESTP_writeixIOSTAT);
3763 errl = specified (FFESTP_writeixERR);
3764
3765 #undef specified
3766
3767 ffeste_start_stmt_ ();
3768
3769 ffeste_io_end_ = NULL_TREE;
3770
3771 if (errl)
3772 {
3773 /* Have ERR= specification. */
3774
3775 ffeste_io_err_
3776 = ffeste_io_abort_
3777 = ffecom_lookup_label
3778 (info->write_spec[FFESTP_writeixERR].u.label);
3779 ffeste_io_abort_is_temp_ = FALSE;
3780 }
3781 else
3782 {
3783 /* No ERR= specification. */
3784
3785 ffeste_io_err_ = NULL_TREE;
3786
3787 if ((ffeste_io_abort_is_temp_ = iostat))
3788 ffeste_io_abort_ = ffecom_temp_label ();
3789 else
3790 ffeste_io_abort_ = NULL_TREE;
3791 }
3792
3793 if (iostat)
3794 {
3795 /* Have IOSTAT= specification. */
3796
3797 ffeste_io_iostat_is_temp_ = FALSE;
3798 ffeste_io_iostat_ = ffecom_expr
3799 (info->write_spec[FFESTP_writeixIOSTAT].u.expr);
3800 }
3801 else if (ffeste_io_abort_ != NULL_TREE)
3802 {
3803 /* Have no IOSTAT= but have ERR=. */
3804
3805 ffeste_io_iostat_is_temp_ = TRUE;
3806 ffeste_io_iostat_
3807 = ffecom_make_tempvar ("write", ffecom_integer_type_node,
3808 FFETARGET_charactersizeNONE, -1);
3809 }
3810 else
3811 {
3812 /* No IOSTAT= or ERR= specification. */
3813
3814 ffeste_io_iostat_is_temp_ = FALSE;
3815 ffeste_io_iostat_ = NULL_TREE;
3816 }
3817
3818 /* Now prescan, then convert, all the arguments. */
3819
3820 if (unit == FFESTV_unitCHAREXPR)
3821 cilist = ffeste_io_icilist_ (errl || iostat,
3822 info->write_spec[FFESTP_writeixUNIT].u.expr,
3823 FALSE, format,
3824 &info->write_spec[FFESTP_writeixFORMAT]);
3825 else
3826 cilist = ffeste_io_cilist_ (errl || iostat, unit,
3827 info->write_spec[FFESTP_writeixUNIT].u.expr,
3828 6, FALSE, format,
3829 &info->write_spec[FFESTP_writeixFORMAT],
3830 rec,
3831 info->write_spec[FFESTP_writeixREC].u.expr);
3832
3833 /* If there is no end function, then there are no item functions (i.e.
3834 it's a NAMELIST), and vice versa by the way. In this situation, don't
3835 generate the "if (iostat != 0) goto label;" if the label is temp abort
3836 label, since we're gonna fall through to there anyway. */
3837
3838 ffeste_io_call_ (ffecom_call_gfrt (start, cilist, NULL_TREE),
3839 (! ffeste_io_abort_is_temp_) || (end != FFECOM_gfrt));
3840 }
3841
3842 /* WRITE statement -- I/O item. */
3843
3844 void
3845 ffeste_R910_item (ffebld expr, ffelexToken expr_token)
3846 {
3847 ffeste_check_item_ ();
3848
3849 if (expr == NULL)
3850 return;
3851
3852 if (ffebld_op (expr) == FFEBLD_opANY)
3853 return;
3854
3855 if (ffebld_op (expr) == FFEBLD_opIMPDO)
3856 ffeste_io_impdo_ (expr, expr_token);
3857 else
3858 {
3859 ffeste_start_stmt_ ();
3860
3861 ffecom_prepare_arg_ptr_to_expr (expr);
3862
3863 ffecom_prepare_end ();
3864
3865 ffeste_io_call_ ((*ffeste_io_driver_) (expr), TRUE);
3866
3867 ffeste_end_stmt_ ();
3868 }
3869 }
3870
3871 /* WRITE statement -- end. */
3872
3873 void
3874 ffeste_R910_finish ()
3875 {
3876 ffeste_check_finish_ ();
3877
3878 /* Don't generate "if (iostat != 0) goto label;" if label is temp abort
3879 label, since we're gonna fall through to there anyway. */
3880
3881 if (ffeste_io_endgfrt_ != FFECOM_gfrt)
3882 ffeste_io_call_ (ffecom_call_gfrt (ffeste_io_endgfrt_, NULL_TREE,
3883 NULL_TREE),
3884 ! ffeste_io_abort_is_temp_);
3885
3886 /* If we've got a temp label, generate its code here. */
3887
3888 if (ffeste_io_abort_is_temp_)
3889 {
3890 DECL_INITIAL (ffeste_io_abort_) = error_mark_node;
3891 emit_nop ();
3892 expand_label (ffeste_io_abort_);
3893
3894 assert (ffeste_io_err_ == NULL_TREE);
3895 }
3896
3897 ffeste_end_stmt_ ();
3898 }
3899
3900 /* PRINT statement -- start. */
3901
3902 void
3903 ffeste_R911_start (ffestpPrintStmt *info, ffestvFormat format)
3904 {
3905 ffecomGfrt start;
3906 ffecomGfrt end;
3907 tree cilist;
3908
3909 ffeste_check_start_ ();
3910
3911 ffeste_emit_line_note_ ();
3912
3913 /* First determine the start, per-item, and end run-time functions to
3914 call. The per-item function is picked by choosing an ffeste function
3915 to call to handle a given item; it knows how to generate a call to the
3916 appropriate run-time function, and is called an "I/O driver". */
3917
3918 switch (format)
3919 {
3920 case FFESTV_formatLABEL: /* FMT=10 */
3921 case FFESTV_formatCHAREXPR: /* FMT='(I10)' */
3922 case FFESTV_formatINTEXPR: /* FMT=I [after ASSIGN 10 TO I] */
3923 ffeste_io_driver_ = ffeste_io_dofio_;
3924 start = FFECOM_gfrtSWSFE, end = FFECOM_gfrtEWSFE;
3925 break;
3926
3927 case FFESTV_formatASTERISK: /* FMT=* */
3928 ffeste_io_driver_ = ffeste_io_dolio_;
3929 start = FFECOM_gfrtSWSLE, end = FFECOM_gfrtEWSLE;
3930 break;
3931
3932 case FFESTV_formatNAMELIST: /* FMT=FOO or NML=FOO [NAMELIST
3933 /FOO/] */
3934 ffeste_io_driver_ = NULL; /* No start or driver function. */
3935 start = FFECOM_gfrtSWSNE, end = FFECOM_gfrt;
3936 break;
3937
3938 default:
3939 assert ("Weird stuff" == NULL);
3940 start = FFECOM_gfrt, end = FFECOM_gfrt;
3941 break;
3942 }
3943 ffeste_io_endgfrt_ = end;
3944
3945 ffeste_start_stmt_ ();
3946
3947 ffeste_io_end_ = NULL_TREE;
3948 ffeste_io_err_ = NULL_TREE;
3949 ffeste_io_abort_ = NULL_TREE;
3950 ffeste_io_abort_is_temp_ = FALSE;
3951 ffeste_io_iostat_is_temp_ = FALSE;
3952 ffeste_io_iostat_ = NULL_TREE;
3953
3954 /* Now prescan, then convert, all the arguments. */
3955
3956 cilist = ffeste_io_cilist_ (FALSE, FFESTV_unitNONE, NULL, 6, FALSE, format,
3957 &info->print_spec[FFESTP_printixFORMAT],
3958 FALSE, NULL);
3959
3960 /* If there is no end function, then there are no item functions (i.e.
3961 it's a NAMELIST), and vice versa by the way. In this situation, don't
3962 generate the "if (iostat != 0) goto label;" if the label is temp abort
3963 label, since we're gonna fall through to there anyway. */
3964
3965 ffeste_io_call_ (ffecom_call_gfrt (start, cilist, NULL_TREE),
3966 (! ffeste_io_abort_is_temp_) || (end != FFECOM_gfrt));
3967 }
3968
3969 /* PRINT statement -- I/O item. */
3970
3971 void
3972 ffeste_R911_item (ffebld expr, ffelexToken expr_token)
3973 {
3974 ffeste_check_item_ ();
3975
3976 if (expr == NULL)
3977 return;
3978
3979 if (ffebld_op (expr) == FFEBLD_opANY)
3980 return;
3981
3982 if (ffebld_op (expr) == FFEBLD_opIMPDO)
3983 ffeste_io_impdo_ (expr, expr_token);
3984 else
3985 {
3986 ffeste_start_stmt_ ();
3987
3988 ffecom_prepare_arg_ptr_to_expr (expr);
3989
3990 ffecom_prepare_end ();
3991
3992 ffeste_io_call_ ((*ffeste_io_driver_) (expr), TRUE);
3993
3994 ffeste_end_stmt_ ();
3995 }
3996 }
3997
3998 /* PRINT statement -- end. */
3999
4000 void
4001 ffeste_R911_finish ()
4002 {
4003 ffeste_check_finish_ ();
4004
4005 if (ffeste_io_endgfrt_ != FFECOM_gfrt)
4006 ffeste_io_call_ (ffecom_call_gfrt (ffeste_io_endgfrt_, NULL_TREE,
4007 NULL_TREE),
4008 FALSE);
4009
4010 ffeste_end_stmt_ ();
4011 }
4012
4013 /* BACKSPACE statement. */
4014
4015 void
4016 ffeste_R919 (ffestpBeruStmt *info)
4017 {
4018 ffeste_check_simple_ ();
4019
4020 ffeste_subr_beru_ (info, FFECOM_gfrtFBACK);
4021 }
4022
4023 /* ENDFILE statement. */
4024
4025 void
4026 ffeste_R920 (ffestpBeruStmt *info)
4027 {
4028 ffeste_check_simple_ ();
4029
4030 ffeste_subr_beru_ (info, FFECOM_gfrtFEND);
4031 }
4032
4033 /* REWIND statement. */
4034
4035 void
4036 ffeste_R921 (ffestpBeruStmt *info)
4037 {
4038 ffeste_check_simple_ ();
4039
4040 ffeste_subr_beru_ (info, FFECOM_gfrtFREW);
4041 }
4042
4043 /* INQUIRE statement (non-IOLENGTH version). */
4044
4045 void
4046 ffeste_R923A (ffestpInquireStmt *info, bool by_file UNUSED)
4047 {
4048 tree args;
4049 bool iostat;
4050 bool errl;
4051
4052 ffeste_check_simple_ ();
4053
4054 ffeste_emit_line_note_ ();
4055
4056 #define specified(something) (info->inquire_spec[something].kw_or_val_present)
4057
4058 iostat = specified (FFESTP_inquireixIOSTAT);
4059 errl = specified (FFESTP_inquireixERR);
4060
4061 #undef specified
4062
4063 ffeste_start_stmt_ ();
4064
4065 if (errl)
4066 {
4067 ffeste_io_err_
4068 = ffeste_io_abort_
4069 = ffecom_lookup_label
4070 (info->inquire_spec[FFESTP_inquireixERR].u.label);
4071 ffeste_io_abort_is_temp_ = FALSE;
4072 }
4073 else
4074 {
4075 ffeste_io_err_ = NULL_TREE;
4076
4077 if ((ffeste_io_abort_is_temp_ = iostat))
4078 ffeste_io_abort_ = ffecom_temp_label ();
4079 else
4080 ffeste_io_abort_ = NULL_TREE;
4081 }
4082
4083 if (iostat)
4084 {
4085 /* Have IOSTAT= specification. */
4086
4087 ffeste_io_iostat_is_temp_ = FALSE;
4088 ffeste_io_iostat_ = ffecom_expr
4089 (info->inquire_spec[FFESTP_inquireixIOSTAT].u.expr);
4090 }
4091 else if (ffeste_io_abort_ != NULL_TREE)
4092 {
4093 /* Have no IOSTAT= but have ERR=. */
4094
4095 ffeste_io_iostat_is_temp_ = TRUE;
4096 ffeste_io_iostat_
4097 = ffecom_make_tempvar ("inquire", ffecom_integer_type_node,
4098 FFETARGET_charactersizeNONE, -1);
4099 }
4100 else
4101 {
4102 /* No IOSTAT= or ERR= specification. */
4103
4104 ffeste_io_iostat_is_temp_ = FALSE;
4105 ffeste_io_iostat_ = NULL_TREE;
4106 }
4107
4108 /* Now prescan, then convert, all the arguments. */
4109
4110 args
4111 = ffeste_io_inlist_ (errl || iostat,
4112 &info->inquire_spec[FFESTP_inquireixUNIT],
4113 &info->inquire_spec[FFESTP_inquireixFILE],
4114 &info->inquire_spec[FFESTP_inquireixEXIST],
4115 &info->inquire_spec[FFESTP_inquireixOPENED],
4116 &info->inquire_spec[FFESTP_inquireixNUMBER],
4117 &info->inquire_spec[FFESTP_inquireixNAMED],
4118 &info->inquire_spec[FFESTP_inquireixNAME],
4119 &info->inquire_spec[FFESTP_inquireixACCESS],
4120 &info->inquire_spec[FFESTP_inquireixSEQUENTIAL],
4121 &info->inquire_spec[FFESTP_inquireixDIRECT],
4122 &info->inquire_spec[FFESTP_inquireixFORM],
4123 &info->inquire_spec[FFESTP_inquireixFORMATTED],
4124 &info->inquire_spec[FFESTP_inquireixUNFORMATTED],
4125 &info->inquire_spec[FFESTP_inquireixRECL],
4126 &info->inquire_spec[FFESTP_inquireixNEXTREC],
4127 &info->inquire_spec[FFESTP_inquireixBLANK]);
4128
4129 /* Don't generate "if (iostat != 0) goto label;" if label is temp abort
4130 label, since we're gonna fall through to there anyway. */
4131
4132 ffeste_io_call_ (ffecom_call_gfrt (FFECOM_gfrtFINQU, args, NULL_TREE),
4133 ! ffeste_io_abort_is_temp_);
4134
4135 /* If we've got a temp label, generate its code here. */
4136
4137 if (ffeste_io_abort_is_temp_)
4138 {
4139 DECL_INITIAL (ffeste_io_abort_) = error_mark_node;
4140 emit_nop ();
4141 expand_label (ffeste_io_abort_);
4142
4143 assert (ffeste_io_err_ == NULL_TREE);
4144 }
4145
4146 ffeste_end_stmt_ ();
4147 }
4148
4149 /* INQUIRE(IOLENGTH=expr) statement -- start. */
4150
4151 void
4152 ffeste_R923B_start (ffestpInquireStmt *info UNUSED)
4153 {
4154 ffeste_check_start_ ();
4155
4156 assert ("INQUIRE(IOLENGTH=<var>) not implemented yet! ~~~" == NULL);
4157
4158 ffeste_emit_line_note_ ();
4159 }
4160
4161 /* INQUIRE(IOLENGTH=expr) statement -- I/O item. */
4162
4163 void
4164 ffeste_R923B_item (ffebld expr UNUSED)
4165 {
4166 ffeste_check_item_ ();
4167 }
4168
4169 /* INQUIRE(IOLENGTH=expr) statement -- end. */
4170
4171 void
4172 ffeste_R923B_finish ()
4173 {
4174 ffeste_check_finish_ ();
4175 }
4176
4177 /* ffeste_R1001 -- FORMAT statement
4178
4179 ffeste_R1001(format_list); */
4180
4181 void
4182 ffeste_R1001 (ffests s)
4183 {
4184 tree t;
4185 tree ttype;
4186 tree maxindex;
4187 tree var;
4188
4189 ffeste_check_simple_ ();
4190
4191 assert (ffeste_label_formatdef_ != NULL);
4192
4193 ffeste_emit_line_note_ ();
4194
4195 t = build_string (ffests_length (s), ffests_text (s));
4196
4197 TREE_TYPE (t)
4198 = build_type_variant (build_array_type
4199 (char_type_node,
4200 build_range_type (integer_type_node,
4201 integer_one_node,
4202 build_int_2 (ffests_length (s),
4203 0))),
4204 1, 0);
4205 TREE_CONSTANT (t) = 1;
4206 TREE_STATIC (t) = 1;
4207
4208 var = ffecom_lookup_label (ffeste_label_formatdef_);
4209 if ((var != NULL_TREE)
4210 && (TREE_CODE (var) == VAR_DECL))
4211 {
4212 DECL_INITIAL (var) = t;
4213 maxindex = build_int_2 (ffests_length (s) - 1, 0);
4214 ttype = TREE_TYPE (var);
4215 TYPE_DOMAIN (ttype) = build_range_type (integer_type_node,
4216 integer_zero_node,
4217 maxindex);
4218 if (!TREE_TYPE (maxindex))
4219 TREE_TYPE (maxindex) = TYPE_DOMAIN (ttype);
4220 layout_type (ttype);
4221 rest_of_decl_compilation (var, NULL, 1, 0);
4222 expand_decl (var);
4223 expand_decl_init (var);
4224 }
4225
4226 ffeste_label_formatdef_ = NULL;
4227 }
4228
4229 /* END PROGRAM. */
4230
4231 void
4232 ffeste_R1103 ()
4233 {
4234 }
4235
4236 /* END BLOCK DATA. */
4237
4238 void
4239 ffeste_R1112 ()
4240 {
4241 }
4242
4243 /* CALL statement. */
4244
4245 void
4246 ffeste_R1212 (ffebld expr)
4247 {
4248 ffebld args;
4249 ffebld arg;
4250 ffebld labels = NULL; /* First in list of LABTERs. */
4251 ffebld prevlabels = NULL;
4252 ffebld prevargs = NULL;
4253
4254 ffeste_check_simple_ ();
4255
4256 args = ffebld_right (expr);
4257
4258 ffeste_emit_line_note_ ();
4259
4260 /* Here we split the list at ffebld_right(expr) into two lists: one at
4261 ffebld_right(expr) consisting of all items that are not LABTERs, the
4262 other at labels consisting of all items that are LABTERs. Then, if
4263 the latter list is NULL, we have an ordinary call, else we have a call
4264 with alternate returns. */
4265
4266 for (args = ffebld_right (expr); args != NULL; args = ffebld_trail (args))
4267 {
4268 if (((arg = ffebld_head (args)) == NULL)
4269 || (ffebld_op (arg) != FFEBLD_opLABTER))
4270 {
4271 if (prevargs == NULL)
4272 {
4273 prevargs = args;
4274 ffebld_set_right (expr, args);
4275 }
4276 else
4277 {
4278 ffebld_set_trail (prevargs, args);
4279 prevargs = args;
4280 }
4281 }
4282 else
4283 {
4284 if (prevlabels == NULL)
4285 {
4286 prevlabels = labels = args;
4287 }
4288 else
4289 {
4290 ffebld_set_trail (prevlabels, args);
4291 prevlabels = args;
4292 }
4293 }
4294 }
4295 if (prevlabels == NULL)
4296 labels = NULL;
4297 else
4298 ffebld_set_trail (prevlabels, NULL);
4299 if (prevargs == NULL)
4300 ffebld_set_right (expr, NULL);
4301 else
4302 ffebld_set_trail (prevargs, NULL);
4303
4304 ffeste_start_stmt_ ();
4305
4306 /* No temporaries are actually needed at this level, but we go
4307 through the motions anyway, just to be sure in case they do
4308 get made. Temporaries needed for arguments should be in the
4309 scopes of inner blocks, and if clean-up actions are supported,
4310 such as CALL-ing an intrinsic that writes to an argument of one
4311 type when a variable of a different type is provided (requiring
4312 assignment to the variable from a temporary after the library
4313 routine returns), the clean-up must be done by the expression
4314 evaluator, generally, to handle alternate returns (which we hope
4315 won't ever be supported by intrinsics, but might be a similar
4316 issue, such as CALL-ing an F90-style subroutine with an INTERFACE
4317 block). That implies the expression evaluator will have to
4318 recognize the need for its own temporary anyway, meaning it'll
4319 construct a block within the one constructed here. */
4320
4321 ffecom_prepare_expr (expr);
4322
4323 ffecom_prepare_end ();
4324
4325 if (labels == NULL)
4326 expand_expr_stmt (ffecom_expr (expr));
4327 else
4328 {
4329 tree texpr;
4330 tree value;
4331 tree tlabel;
4332 int caseno;
4333 int pushok;
4334 tree duplicate;
4335 ffebld label;
4336
4337 texpr = ffecom_expr (expr);
4338 expand_start_case (0, texpr, TREE_TYPE (texpr), "CALL statement");
4339
4340 for (caseno = 1, label = labels;
4341 label != NULL;
4342 ++caseno, label = ffebld_trail (label))
4343 {
4344 value = build_int_2 (caseno, 0);
4345 tlabel = build_decl (LABEL_DECL, NULL_TREE, NULL_TREE);
4346
4347 pushok = pushcase (value, convert, tlabel, &duplicate);
4348 assert (pushok == 0);
4349
4350 tlabel
4351 = ffecom_lookup_label (ffebld_labter (ffebld_head (label)));
4352 if ((tlabel == NULL_TREE)
4353 || (TREE_CODE (tlabel) == ERROR_MARK))
4354 continue;
4355 TREE_USED (tlabel) = 1;
4356 expand_goto (tlabel);
4357 }
4358
4359 expand_end_case (texpr);
4360 }
4361
4362 ffeste_end_stmt_ ();
4363 }
4364
4365 /* END FUNCTION. */
4366
4367 void
4368 ffeste_R1221 ()
4369 {
4370 }
4371
4372 /* END SUBROUTINE. */
4373
4374 void
4375 ffeste_R1225 ()
4376 {
4377 }
4378
4379 /* ENTRY statement. */
4380
4381 void
4382 ffeste_R1226 (ffesymbol entry)
4383 {
4384 tree label;
4385
4386 ffeste_check_simple_ ();
4387
4388 label = ffesymbol_hook (entry).length_tree;
4389
4390 ffeste_emit_line_note_ ();
4391
4392 if (label == error_mark_node)
4393 return;
4394
4395 DECL_INITIAL (label) = error_mark_node;
4396 emit_nop ();
4397 expand_label (label);
4398 }
4399
4400 /* RETURN statement. */
4401
4402 void
4403 ffeste_R1227 (ffestw block UNUSED, ffebld expr)
4404 {
4405 tree rtn;
4406
4407 ffeste_check_simple_ ();
4408
4409 ffeste_emit_line_note_ ();
4410
4411 ffeste_start_stmt_ ();
4412
4413 ffecom_prepare_return_expr (expr);
4414
4415 ffecom_prepare_end ();
4416
4417 rtn = ffecom_return_expr (expr);
4418
4419 if ((rtn == NULL_TREE)
4420 || (rtn == error_mark_node))
4421 expand_null_return ();
4422 else
4423 {
4424 tree result = DECL_RESULT (current_function_decl);
4425
4426 if ((result != error_mark_node)
4427 && (TREE_TYPE (result) != error_mark_node))
4428 expand_return (ffecom_modify (NULL_TREE,
4429 result,
4430 convert (TREE_TYPE (result),
4431 rtn)));
4432 else
4433 expand_null_return ();
4434 }
4435
4436 ffeste_end_stmt_ ();
4437 }
4438
4439 /* REWRITE statement -- start. */
4440
4441 #if FFESTR_VXT
4442 void
4443 ffeste_V018_start (ffestpRewriteStmt *info, ffestvFormat format)
4444 {
4445 ffeste_check_start_ ();
4446 }
4447
4448 /* REWRITE statement -- I/O item. */
4449
4450 void
4451 ffeste_V018_item (ffebld expr)
4452 {
4453 ffeste_check_item_ ();
4454 }
4455
4456 /* REWRITE statement -- end. */
4457
4458 void
4459 ffeste_V018_finish ()
4460 {
4461 ffeste_check_finish_ ();
4462 }
4463
4464 /* ACCEPT statement -- start. */
4465
4466 void
4467 ffeste_V019_start (ffestpAcceptStmt *info, ffestvFormat format)
4468 {
4469 ffeste_check_start_ ();
4470 }
4471
4472 /* ACCEPT statement -- I/O item. */
4473
4474 void
4475 ffeste_V019_item (ffebld expr)
4476 {
4477 ffeste_check_item_ ();
4478 }
4479
4480 /* ACCEPT statement -- end. */
4481
4482 void
4483 ffeste_V019_finish ()
4484 {
4485 ffeste_check_finish_ ();
4486 }
4487
4488 #endif
4489 /* TYPE statement -- start. */
4490
4491 void
4492 ffeste_V020_start (ffestpTypeStmt *info UNUSED,
4493 ffestvFormat format UNUSED)
4494 {
4495 ffeste_check_start_ ();
4496 }
4497
4498 /* TYPE statement -- I/O item. */
4499
4500 void
4501 ffeste_V020_item (ffebld expr UNUSED)
4502 {
4503 ffeste_check_item_ ();
4504 }
4505
4506 /* TYPE statement -- end. */
4507
4508 void
4509 ffeste_V020_finish ()
4510 {
4511 ffeste_check_finish_ ();
4512 }
4513
4514 /* DELETE statement. */
4515
4516 #if FFESTR_VXT
4517 void
4518 ffeste_V021 (ffestpDeleteStmt *info)
4519 {
4520 ffeste_check_simple_ ();
4521 }
4522
4523 /* UNLOCK statement. */
4524
4525 void
4526 ffeste_V022 (ffestpBeruStmt *info)
4527 {
4528 ffeste_check_simple_ ();
4529 }
4530
4531 /* ENCODE statement -- start. */
4532
4533 void
4534 ffeste_V023_start (ffestpVxtcodeStmt *info)
4535 {
4536 ffeste_check_start_ ();
4537 }
4538
4539 /* ENCODE statement -- I/O item. */
4540
4541 void
4542 ffeste_V023_item (ffebld expr)
4543 {
4544 ffeste_check_item_ ();
4545 }
4546
4547 /* ENCODE statement -- end. */
4548
4549 void
4550 ffeste_V023_finish ()
4551 {
4552 ffeste_check_finish_ ();
4553 }
4554
4555 /* DECODE statement -- start. */
4556
4557 void
4558 ffeste_V024_start (ffestpVxtcodeStmt *info)
4559 {
4560 ffeste_check_start_ ();
4561 }
4562
4563 /* DECODE statement -- I/O item. */
4564
4565 void
4566 ffeste_V024_item (ffebld expr)
4567 {
4568 ffeste_check_item_ ();
4569 }
4570
4571 /* DECODE statement -- end. */
4572
4573 void
4574 ffeste_V024_finish ()
4575 {
4576 ffeste_check_finish_ ();
4577 }
4578
4579 /* DEFINEFILE statement -- start. */
4580
4581 void
4582 ffeste_V025_start ()
4583 {
4584 ffeste_check_start_ ();
4585 }
4586
4587 /* DEFINE FILE statement -- item. */
4588
4589 void
4590 ffeste_V025_item (ffebld u, ffebld m, ffebld n, ffebld asv)
4591 {
4592 ffeste_check_item_ ();
4593 }
4594
4595 /* DEFINE FILE statement -- end. */
4596
4597 void
4598 ffeste_V025_finish ()
4599 {
4600 ffeste_check_finish_ ();
4601 }
4602
4603 /* FIND statement. */
4604
4605 void
4606 ffeste_V026 (ffestpFindStmt *info)
4607 {
4608 ffeste_check_simple_ ();
4609 }
4610
4611 #endif
4612
4613 #ifdef ENABLE_CHECKING
4614 void
4615 ffeste_terminate_2 (void)
4616 {
4617 assert (! ffeste_top_block_);
4618 }
4619 #endif
Mirror of the offical gcc git repository hosted at gcc.gnu.org