1 /* ste.c -- Implementation File (module.c template V1.0)
2 Copyright (C) 1995, 1996, 2000, 2002 Free Software Foundation, Inc.
3 Contributed by James Craig Burley.
5 This file is part of GNU Fortran.
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)
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.
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
26 Implements the various statements and such like.
52 /* Externals defined here. */
55 /* Simple definitions and enumerations. */
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. */
66 /* Internal typedefs. */
69 /* Private include files. */
72 /* Internal structure definitions. */
75 /* Static objects accessed by functions in this module. */
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. */
88 /* Static functions (internal). */
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,
96 static void ffeste_end_iterdo_ (ffestw block, tree tvar, tree tincr,
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,
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);
141 /* Internal macros. */
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_
170 #define ffeste_f2c_init_charnolen_(Exp,Init,Spec) \
173 if ((Spec)->kw_or_val_present) \
174 Exp = ffecom_arg_ptr_to_const_expr ((Spec)->u.expr, &ignore); \
176 Exp = null_pointer_node; \
181 Init = null_pointer_node; \
186 #define ffeste_f2c_init_char_(Exp,Init,Lenexp,Leninit,Spec) \
189 if ((Spec)->kw_or_val_present) \
190 Exp = ffecom_arg_ptr_to_const_expr ((Spec)->u.expr, &Lenexp); \
193 Exp = null_pointer_node; \
194 Lenexp = ffecom_f2c_ftnlen_zero_node; \
200 Init = null_pointer_node; \
207 Leninit = ffecom_f2c_ftnlen_zero_node; \
212 #define ffeste_f2c_init_flag_(Flag,Init) \
215 Init = convert (ffecom_f2c_flag_type_node, \
216 (Flag) ? integer_one_node : integer_zero_node); \
219 #define ffeste_f2c_init_format_(Exp,Init,Spec) \
222 Exp = ffecom_arg_ptr_to_const_expr ((Spec)->u.expr, NULL); \
227 Init = null_pointer_node; \
232 #define ffeste_f2c_init_int_(Exp,Init,Spec) \
235 if ((Spec)->kw_or_val_present) \
236 Exp = ffecom_const_expr ((Spec)->u.expr); \
238 Exp = ffecom_integer_zero_node; \
243 Init = ffecom_integer_zero_node; \
248 #define ffeste_f2c_init_ptrtoint_(Exp,Init,Spec) \
251 if ((Spec)->kw_or_val_present) \
252 Exp = ffecom_ptr_to_const_expr ((Spec)->u.expr); \
254 Exp = null_pointer_node; \
259 Init = null_pointer_node; \
264 #define ffeste_f2c_init_next_(Init) \
267 TREE_CHAIN (initn) = build_tree_list ((field = TREE_CHAIN (field)), \
269 initn = TREE_CHAIN(initn); \
272 #define ffeste_f2c_prepare_charnolen_(Spec,Exp) \
276 ffecom_prepare_arg_ptr_to_expr ((Spec)->u.expr); \
279 #define ffeste_f2c_prepare_char_(Spec,Exp) \
283 ffecom_prepare_arg_ptr_to_expr ((Spec)->u.expr); \
286 #define ffeste_f2c_prepare_format_(Spec,Exp) \
290 ffecom_prepare_arg_ptr_to_expr ((Spec)->u.expr); \
293 #define ffeste_f2c_prepare_int_(Spec,Exp) \
297 ffecom_prepare_expr ((Spec)->u.expr); \
300 #define ffeste_f2c_prepare_ptrtoint_(Spec,Exp) \
304 ffecom_prepare_ptr_to_expr ((Spec)->u.expr); \
307 #define ffeste_f2c_compile_(Field,Exp) \
313 exz = ffecom_modify (void_type_node, \
314 ffecom_2 (COMPONENT_REF, TREE_TYPE (Field), \
317 expand_expr_stmt (exz); \
321 #define ffeste_f2c_compile_charnolen_(Field,Spec,Exp) \
327 exq = ffecom_arg_ptr_to_expr ((Spec)->u.expr, &ignore); \
328 ffeste_f2c_compile_ ((Field), exq); \
332 #define ffeste_f2c_compile_char_(Field,Lenfield,Spec,Exp,Lenexp) \
336 tree lenexq = (Lenexp); \
337 int need_exq = (! exq); \
338 int need_lenexq = (! lenexq); \
339 if (need_exq || need_lenexq) \
341 exq = ffecom_arg_ptr_to_expr ((Spec)->u.expr, &lenexq); \
343 ffeste_f2c_compile_ ((Field), exq); \
345 ffeste_f2c_compile_ ((Lenfield), lenexq); \
349 #define ffeste_f2c_compile_format_(Field,Spec,Exp) \
355 exq = ffecom_arg_ptr_to_expr ((Spec)->u.expr, NULL); \
356 ffeste_f2c_compile_ ((Field), exq); \
360 #define ffeste_f2c_compile_int_(Field,Spec,Exp) \
366 exq = ffecom_expr ((Spec)->u.expr); \
367 ffeste_f2c_compile_ ((Field), exq); \
371 #define ffeste_f2c_compile_ptrtoint_(Field,Spec,Exp) \
377 exq = ffecom_ptr_to_expr ((Spec)->u.expr); \
378 ffeste_f2c_compile_ ((Field), exq); \
382 /* Start a Fortran block. */
384 #ifdef ENABLE_CHECKING
386 typedef struct gbe_block
388 struct gbe_block *outer;
391 const char *input_filename;
395 gbe_block ffeste_top_block_ = NULL;
398 ffeste_start_block_ (ffestw block)
400 gbe_block b = xmalloc (sizeof (*b));
402 b->outer = ffeste_top_block_;
405 b->input_filename = input_filename;
408 ffeste_top_block_ = b;
410 ffecom_start_compstmt ();
413 /* End a Fortran block. */
416 ffeste_end_block_ (ffestw block)
418 gbe_block b = ffeste_top_block_;
421 assert (! b->is_stmt);
422 assert (b->block == block);
423 assert (! b->is_stmt);
425 ffeste_top_block_ = b->outer;
429 ffecom_end_compstmt ();
432 /* Start a Fortran statement.
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. */
440 ffeste_start_stmt_(void)
442 gbe_block b = xmalloc (sizeof (*b));
444 b->outer = ffeste_top_block_;
447 b->input_filename = input_filename;
450 ffeste_top_block_ = b;
452 ffecom_start_compstmt ();
455 /* End a Fortran statement. */
458 ffeste_end_stmt_(void)
460 gbe_block b = ffeste_top_block_;
465 ffeste_top_block_ = b->outer;
469 ffecom_end_compstmt ();
472 #else /* ! defined (ENABLE_CHECKING) */
474 #define ffeste_start_block_(b) ffecom_start_compstmt ()
475 #define ffeste_end_block_(b) \
478 ffecom_end_compstmt (); \
480 #define ffeste_start_stmt_() ffeste_start_block_(NULL)
481 #define ffeste_end_stmt_() ffeste_end_block_(NULL)
483 #endif /* ! defined (ENABLE_CHECKING) */
485 /* Begin an iterative DO loop. Pass the block to start if
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,
503 struct nesting *expanded_loop;
505 /* Want to have tvar, tincr, and niters for the whole loop body. */
508 ffeste_start_block_ (block);
510 ffeste_start_stmt_ ();
512 niters = ffecom_make_tempvar (block ? "do" : "impdo",
513 ffecom_integer_type_node,
514 FFETARGET_charactersizeNONE, -1);
516 ffecom_prepare_expr (incr);
517 ffecom_prepare_expr_rw (NULL_TREE, var);
519 ffecom_prepare_end ();
521 tvar = ffecom_expr_rw (NULL_TREE, var);
522 tincr = ffecom_expr (incr);
524 if (TREE_CODE (tvar) == ERROR_MARK
525 || TREE_CODE (tincr) == ERROR_MARK)
529 ffeste_end_block_ (block);
530 ffestw_set_do_tvar (block, error_mark_node);
535 *xtvar = error_mark_node;
540 /* Check whether incr is known to be zero, complain and fix. */
542 if (integer_zerop (tincr) || real_zerop (tincr))
544 ffebad_start (FFEBAD_DO_STEP_ZERO);
545 ffebad_here (0, ffelex_token_where_line (incr_token),
546 ffelex_token_where_column (incr_token));
549 tincr = convert (TREE_TYPE (tvar), integer_one_node);
552 tincr_saved = ffecom_save_tree (tincr);
554 /* Want to have tstart, tend for just this statement. */
556 ffeste_start_stmt_ ();
558 ffecom_prepare_expr (start);
559 ffecom_prepare_expr (end);
561 ffecom_prepare_end ();
563 tstart = ffecom_expr (start);
564 tend = ffecom_expr (end);
566 if (TREE_CODE (tstart) == ERROR_MARK
567 || TREE_CODE (tend) == ERROR_MARK)
573 ffeste_end_block_ (block);
574 ffestw_set_do_tvar (block, error_mark_node);
579 *xtvar = error_mark_node;
584 /* For warnings only, nothing else happens here. */
588 if (! ffe_is_onetrip ())
590 try = ffecom_2 (MINUS_EXPR, TREE_TYPE (tvar),
594 try = ffecom_2 (PLUS_EXPR, TREE_TYPE (tvar),
598 if (TREE_CODE (TREE_TYPE (tvar)) != REAL_TYPE)
599 try = ffecom_2 (TRUNC_DIV_EXPR, integer_type_node, try,
602 try = convert (integer_type_node,
603 ffecom_2 (RDIV_EXPR, TREE_TYPE (tvar),
607 /* Warn if loop never executed, since we've done the evaluation
608 of the unofficial iteration count already. */
610 try = ffecom_truth_value (ffecom_2 (LE_EXPR, integer_type_node,
612 convert (TREE_TYPE (tvar),
613 integer_zero_node)));
615 if (integer_onep (try))
617 ffebad_start (FFEBAD_DO_NULL);
618 ffebad_here (0, ffelex_token_where_line (start_token),
619 ffelex_token_where_column (start_token));
625 /* Warn if end plus incr would overflow. */
627 try = ffecom_2 (PLUS_EXPR, TREE_TYPE (tvar),
631 if ((TREE_CODE_CLASS (TREE_CODE (try)) == 'c')
632 && TREE_CONSTANT_OVERFLOW (try))
634 ffebad_start (FFEBAD_DO_END_OVERFLOW);
635 ffebad_here (0, ffelex_token_where_line (end_token),
636 ffelex_token_where_column (end_token));
642 /* Do the initial assignment into the DO var. */
644 tstart = ffecom_save_tree (tstart);
646 expr = ffecom_2 (MINUS_EXPR, TREE_TYPE (tvar),
650 if (! ffe_is_onetrip ())
652 expr = ffecom_2 (PLUS_EXPR, TREE_TYPE (expr),
654 convert (TREE_TYPE (expr), tincr_saved));
657 if (TREE_CODE (TREE_TYPE (tvar)) != REAL_TYPE)
658 expr = ffecom_2 (TRUNC_DIV_EXPR, TREE_TYPE (expr),
662 expr = ffecom_2 (RDIV_EXPR, TREE_TYPE (expr),
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)))
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);
682 assert (TYPE_MAIN_VARIANT (TREE_TYPE (niters))
683 == TYPE_MAIN_VARIANT (TREE_TYPE (expr)));
685 expr = ffecom_modify (void_type_node, niters, expr);
686 expand_expr_stmt (expr);
688 expr = ffecom_modify (void_type_node, tvar, tstart);
689 expand_expr_stmt (expr);
693 expanded_loop = expand_start_loop_continue_elsewhere (!! block);
695 ffestw_set_do_hook (block, expanded_loop);
697 if (! ffe_is_onetrip ())
699 expr = ffecom_truth_value
700 (ffecom_2 (GE_EXPR, integer_type_node,
701 ffecom_2 (PREDECREMENT_EXPR,
704 convert (TREE_TYPE (niters),
705 ffecom_integer_one_node)),
706 convert (TREE_TYPE (niters),
707 ffecom_integer_zero_node)));
709 expand_exit_loop_top_cond (0, expr);
714 ffestw_set_do_tvar (block, tvar);
715 ffestw_set_do_incr_saved (block, tincr_saved);
716 ffestw_set_do_count_var (block, niters);
721 *xtincr = tincr_saved;
726 /* End an iterative DO loop. Pass the same iteration variable and increment
727 value trees that were generated in the paired _begin_ call. */
730 ffeste_end_iterdo_ (ffestw block, tree tvar, tree tincr, tree itersvar)
733 tree niters = itersvar;
735 if (tvar == error_mark_node)
738 expand_loop_continue_here ();
740 ffeste_start_stmt_ ();
742 if (ffe_is_onetrip ())
744 expr = ffecom_truth_value
745 (ffecom_2 (GE_EXPR, integer_type_node,
746 ffecom_2 (PREDECREMENT_EXPR,
749 convert (TREE_TYPE (niters),
750 ffecom_integer_one_node)),
751 convert (TREE_TYPE (niters),
752 ffecom_integer_zero_node)));
754 expand_exit_loop_if_false (0, expr);
757 expr = ffecom_modify (void_type_node, tvar,
758 ffecom_2 (PLUS_EXPR, TREE_TYPE (tvar),
761 expand_expr_stmt (expr);
763 /* Lose the stuff we just built. */
768 /* Lose the tvar and incr_saved trees. */
770 ffeste_end_block_ (block);
775 /* Generate call to run-time I/O routine. */
778 ffeste_io_call_ (tree call, bool do_check)
780 /* Generate the call and optional assignment into iostat var. */
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);
789 || ffeste_io_abort_ == NULL_TREE
790 || TREE_CODE (ffeste_io_abort_) == ERROR_MARK)
793 /* Generate optional test. */
795 expand_start_cond (ffecom_truth_value (ffeste_io_iostat_), 0);
796 expand_goto (ffeste_io_abort_);
800 /* Handle implied-DO in I/O list.
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. */
807 ffeste_io_impdo_ (ffebld impdo, ffelexToken impdo_token)
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)))));
823 incr = ffebld_new_conter (ffebld_constant_new_integerdefault_val (1));
824 ffebld_set_info (incr, ffeinfo_new
825 (FFEINFO_basictypeINTEGER,
826 FFEINFO_kindtypeINTEGERDEFAULT,
829 FFEINFO_whereCONSTANT,
830 FFETARGET_charactersizeNONE));
833 /* Start the DO loop. */
835 start = ffeexpr_convert_expr (start, impdo_token, var, impdo_token,
837 end = ffeexpr_convert_expr (end, impdo_token, var, impdo_token,
839 incr = ffeexpr_convert_expr (incr, impdo_token, var, impdo_token,
842 ffeste_begin_iterdo_ (NULL, &tvar, &tincr, &titervar, var,
848 /* Handle the list of items. */
850 for (list = ffebld_left (impdo); list != NULL; list = ffebld_trail (list))
852 item = ffebld_head (list);
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);
861 if (ffebld_op (item) == FFEBLD_opANY)
864 if (ffebld_op (item) == FFEBLD_opIMPDO)
865 ffeste_io_impdo_ (item, impdo_token);
868 ffeste_start_stmt_ ();
870 ffecom_prepare_arg_ptr_to_expr (item);
872 ffecom_prepare_end ();
874 ffeste_io_call_ ((*ffeste_io_driver_) (item), TRUE);
880 /* Generate end of implied-do construct. */
882 ffeste_end_iterdo_ (NULL, tvar, tincr, titervar);
885 /* I/O driver for formatted I/O item (do_fio)
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. */
895 ffeste_io_dofio_ (ffebld expr)
905 bt = ffeinfo_basictype (ffebld_info (expr));
906 kt = ffeinfo_kindtype (ffebld_info (expr));
908 if ((bt == FFEINFO_basictypeANY)
909 || (kt == FFEINFO_kindtypeANY))
910 return error_mark_node;
912 if (bt == FFEINFO_basictypeCOMPLEX)
915 bt = FFEINFO_basictypeREAL;
920 variable = ffecom_arg_ptr_to_expr (expr, &size);
922 if ((variable == error_mark_node)
923 || (size == error_mark_node))
924 return error_mark_node;
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)
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)));
939 size = convert (ffecom_f2c_ftnlen_type_node, size);
942 if (ffeinfo_rank (ffebld_info (expr)) == 0
943 || TREE_CODE (TREE_TYPE (TREE_TYPE (variable))) != ARRAY_TYPE)
945 = is_complex ? ffecom_f2c_ftnlen_two_node : ffecom_f2c_ftnlen_one_node;
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)
955 num_elements = convert (ffecom_f2c_ftnlen_type_node,
960 = ffecom_1 (ADDR_EXPR, ffecom_f2c_ptr_to_ftnlen_type_node,
963 variable = convert (string_type_node, variable);
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);
969 return ffecom_call_gfrt (FFECOM_gfrtDOFIO, arglist, NULL_TREE);
972 /* I/O driver for list-directed I/O item (do_lio)
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. */
982 ffeste_io_dolio_ (ffebld expr)
993 bt = ffeinfo_basictype (ffebld_info (expr));
994 kt = ffeinfo_kindtype (ffebld_info (expr));
996 if ((bt == FFEINFO_basictypeANY)
997 || (kt == FFEINFO_kindtypeANY))
998 return error_mark_node;
1000 tc = ffecom_f2c_typecode (bt, kt);
1002 type_id = build_int_2 (tc, 0);
1005 = ffecom_1 (ADDR_EXPR, ffecom_f2c_ptr_to_ftnint_type_node,
1006 convert (ffecom_f2c_ftnint_type_node,
1009 variable = ffecom_arg_ptr_to_expr (expr, &size);
1011 if ((type_id == error_mark_node)
1012 || (variable == error_mark_node)
1013 || (size == error_mark_node))
1014 return error_mark_node;
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)
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)));
1029 size = convert (ffecom_f2c_ftnlen_type_node, size);
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;
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)
1044 num_elements = convert (ffecom_f2c_ftnlen_type_node,
1049 = ffecom_1 (ADDR_EXPR, ffecom_f2c_ptr_to_ftnlen_type_node,
1052 variable = convert (string_type_node, variable);
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);
1060 return ffecom_call_gfrt (FFECOM_gfrtDOLIO, arglist, NULL_TREE);
1063 /* I/O driver for unformatted I/O item (do_uio)
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. */
1073 ffeste_io_douio_ (ffebld expr)
1079 ffeinfoBasictype bt;
1083 bt = ffeinfo_basictype (ffebld_info (expr));
1084 kt = ffeinfo_kindtype (ffebld_info (expr));
1086 if ((bt == FFEINFO_basictypeANY)
1087 || (kt == FFEINFO_kindtypeANY))
1088 return error_mark_node;
1090 if (bt == FFEINFO_basictypeCOMPLEX)
1093 bt = FFEINFO_basictypeREAL;
1098 variable = ffecom_arg_ptr_to_expr (expr, &size);
1100 if ((variable == error_mark_node)
1101 || (size == error_mark_node))
1102 return error_mark_node;
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)
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)));
1117 size = convert (ffecom_f2c_ftnlen_type_node, size);
1120 if (ffeinfo_rank (ffebld_info (expr)) == 0
1121 || TREE_CODE (TREE_TYPE (TREE_TYPE (variable))) != ARRAY_TYPE)
1123 = is_complex ? ffecom_f2c_ftnlen_two_node : ffecom_f2c_ftnlen_one_node;
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)
1133 num_elements = convert (ffecom_f2c_ftnlen_type_node,
1138 = ffecom_1 (ADDR_EXPR, ffecom_f2c_ptr_to_ftnlen_type_node,
1141 variable = convert (string_type_node, variable);
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);
1147 return ffecom_call_gfrt (FFECOM_gfrtDOUIO, arglist, NULL_TREE);
1150 /* Make arglist with ptr to BACKSPACE/ENDFILE/REWIND control list.
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.
1157 Must ensure that all expressions are prepared before being evaluated,
1158 for any whose evaluation might result in the generation of temporaries.
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,
1166 ffeste_io_ialist_ (bool have_err,
1171 static tree f2c_alist_struct = NULL_TREE;
1176 bool constantp = TRUE;
1177 static tree errfield, unitfield;
1178 tree errinit, unitinit;
1180 static int mynumber = 0;
1182 if (f2c_alist_struct == NULL_TREE)
1186 ref = make_node (RECORD_TYPE);
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);
1193 TYPE_FIELDS (ref) = errfield;
1196 ggc_add_tree_root (&f2c_alist_struct, 1);
1198 f2c_alist_struct = ref;
1201 /* Try to do as much compile-time initialization of the structure
1202 as possible, to save run time. */
1204 ffeste_f2c_init_flag_ (have_err, errinit);
1208 case FFESTV_unitNONE:
1209 case FFESTV_unitASTERISK:
1210 unitinit = build_int_2 (unit_dflt, 0);
1214 case FFESTV_unitINTEXPR:
1215 unitexp = ffecom_const_expr (unit_expr);
1220 unitinit = ffecom_integer_zero_node;
1226 assert ("bad unit spec" == NULL);
1227 unitinit = ffecom_integer_zero_node;
1232 inits = build_tree_list ((field = TYPE_FIELDS (f2c_alist_struct)), errinit);
1234 ffeste_f2c_init_next_ (unitinit);
1236 inits = build (CONSTRUCTOR, f2c_alist_struct, NULL_TREE, inits);
1237 TREE_CONSTANT (inits) = constantp ? 1 : 0;
1238 TREE_STATIC (inits) = 1;
1240 t = build_decl (VAR_DECL,
1241 ffecom_get_invented_identifier ("__g77_alist_%d",
1244 TREE_STATIC (t) = 1;
1245 t = ffecom_start_decl (t, 1);
1246 ffecom_finish_decl (t, inits, 0);
1248 /* Prepare run-time expressions. */
1251 ffecom_prepare_expr (unit_expr);
1253 ffecom_prepare_end ();
1255 /* Now evaluate run-time expressions as needed. */
1259 unitexp = ffecom_expr (unit_expr);
1260 ffeste_f2c_compile_ (unitfield, unitexp);
1263 ttype = build_pointer_type (TREE_TYPE (t));
1264 t = ffecom_1 (ADDR_EXPR, ttype, t);
1266 t = build_tree_list (NULL_TREE, t);
1271 /* Make arglist with ptr to external-I/O control list.
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.
1278 Must ensure that all expressions are prepared before being evaluated,
1279 for any whose evaluation might result in the generation of temporaries.
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,
1287 ffeste_io_cilist_ (bool have_err,
1292 ffestvFormat format,
1293 ffestpFile *format_spec,
1297 static tree f2c_cilist_struct = NULL_TREE;
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;
1308 if (f2c_cilist_struct == NULL_TREE)
1312 ref = make_node (RECORD_TYPE);
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",
1322 recfield = ffecom_decl_field (ref, formatfield, "rec",
1323 ffecom_f2c_ftnint_type_node);
1325 TYPE_FIELDS (ref) = errfield;
1328 ggc_add_tree_root (&f2c_cilist_struct, 1);
1330 f2c_cilist_struct = ref;
1333 /* Try to do as much compile-time initialization of the structure
1334 as possible, to save run time. */
1336 ffeste_f2c_init_flag_ (have_err, errinit);
1340 case FFESTV_unitNONE:
1341 case FFESTV_unitASTERISK:
1342 unitinit = build_int_2 (unit_dflt, 0);
1346 case FFESTV_unitINTEXPR:
1347 unitexp = ffecom_const_expr (unit_expr);
1352 unitinit = ffecom_integer_zero_node;
1358 assert ("bad unit spec" == NULL);
1359 unitinit = ffecom_integer_zero_node;
1366 case FFESTV_formatNONE:
1367 formatinit = null_pointer_node;
1368 formatexp = formatinit;
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))
1377 formatinit = ffecom_1 (ADDR_EXPR,
1378 build_pointer_type (void_type_node),
1380 TREE_CONSTANT (formatinit) = 1;
1383 case FFESTV_formatCHAREXPR:
1384 formatexp = ffecom_arg_ptr_to_const_expr (format_spec->u.expr, NULL);
1386 formatinit = formatexp;
1389 formatinit = null_pointer_node;
1394 case FFESTV_formatASTERISK:
1395 formatinit = null_pointer_node;
1396 formatexp = formatinit;
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);
1408 case FFESTV_formatNAMELIST:
1409 formatinit = ffecom_expr (format_spec->u.expr);
1410 formatexp = formatinit;
1414 assert ("bad format spec" == NULL);
1415 formatinit = integer_zero_node;
1416 formatexp = formatinit;
1420 ffeste_f2c_init_flag_ (have_end, endinit);
1423 recexp = ffecom_const_expr (rec_expr);
1425 recexp = ffecom_integer_zero_node;
1430 recinit = ffecom_integer_zero_node;
1434 inits = build_tree_list ((field = TYPE_FIELDS (f2c_cilist_struct)), errinit);
1436 ffeste_f2c_init_next_ (unitinit);
1437 ffeste_f2c_init_next_ (endinit);
1438 ffeste_f2c_init_next_ (formatinit);
1439 ffeste_f2c_init_next_ (recinit);
1441 inits = build (CONSTRUCTOR, f2c_cilist_struct, NULL_TREE, inits);
1442 TREE_CONSTANT (inits) = constantp ? 1 : 0;
1443 TREE_STATIC (inits) = 1;
1445 t = build_decl (VAR_DECL,
1446 ffecom_get_invented_identifier ("__g77_cilist_%d",
1449 TREE_STATIC (t) = 1;
1450 t = ffecom_start_decl (t, 1);
1451 ffecom_finish_decl (t, inits, 0);
1453 /* Prepare run-time expressions. */
1456 ffecom_prepare_expr (unit_expr);
1459 ffecom_prepare_arg_ptr_to_expr (format_spec->u.expr);
1462 ffecom_prepare_expr (rec_expr);
1464 ffecom_prepare_end ();
1466 /* Now evaluate run-time expressions as needed. */
1470 unitexp = ffecom_expr (unit_expr);
1471 ffeste_f2c_compile_ (unitfield, unitexp);
1476 formatexp = ffecom_arg_ptr_to_expr (format_spec->u.expr, NULL);
1477 ffeste_f2c_compile_ (formatfield, formatexp);
1479 else if (format == FFESTV_formatINTEXPR)
1480 ffeste_f2c_compile_ (formatfield, formatexp);
1484 recexp = ffecom_expr (rec_expr);
1485 ffeste_f2c_compile_ (recfield, recexp);
1488 ttype = build_pointer_type (TREE_TYPE (t));
1489 t = ffecom_1 (ADDR_EXPR, ttype, t);
1491 t = build_tree_list (NULL_TREE, t);
1496 /* Make arglist with ptr to CLOSE control list.
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.
1503 Must ensure that all expressions are prepared before being evaluated,
1504 for any whose evaluation might result in the generation of temporaries.
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,
1512 ffeste_io_cllist_ (bool have_err,
1514 ffestpFile *stat_spec)
1516 static tree f2c_close_struct = NULL_TREE;
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;
1528 if (f2c_close_struct == NULL_TREE)
1532 ref = make_node (RECORD_TYPE);
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",
1541 TYPE_FIELDS (ref) = errfield;
1544 ggc_add_tree_root (&f2c_close_struct, 1);
1546 f2c_close_struct = ref;
1549 /* Try to do as much compile-time initialization of the structure
1550 as possible, to save run time. */
1552 ffeste_f2c_init_flag_ (have_err, errinit);
1554 unitexp = ffecom_const_expr (unit_expr);
1559 unitinit = ffecom_integer_zero_node;
1563 ffeste_f2c_init_charnolen_ (statexp, statinit, stat_spec);
1565 inits = build_tree_list ((field = TYPE_FIELDS (f2c_close_struct)), errinit);
1567 ffeste_f2c_init_next_ (unitinit);
1568 ffeste_f2c_init_next_ (statinit);
1570 inits = build (CONSTRUCTOR, f2c_close_struct, NULL_TREE, inits);
1571 TREE_CONSTANT (inits) = constantp ? 1 : 0;
1572 TREE_STATIC (inits) = 1;
1574 t = build_decl (VAR_DECL,
1575 ffecom_get_invented_identifier ("__g77_cllist_%d",
1578 TREE_STATIC (t) = 1;
1579 t = ffecom_start_decl (t, 1);
1580 ffecom_finish_decl (t, inits, 0);
1582 /* Prepare run-time expressions. */
1585 ffecom_prepare_expr (unit_expr);
1588 ffecom_prepare_arg_ptr_to_expr (stat_spec->u.expr);
1590 ffecom_prepare_end ();
1592 /* Now evaluate run-time expressions as needed. */
1596 unitexp = ffecom_expr (unit_expr);
1597 ffeste_f2c_compile_ (unitfield, unitexp);
1600 ffeste_f2c_compile_charnolen_ (statfield, stat_spec, statexp);
1602 ttype = build_pointer_type (TREE_TYPE (t));
1603 t = ffecom_1 (ADDR_EXPR, ttype, t);
1605 t = build_tree_list (NULL_TREE, t);
1610 /* Make arglist with ptr to internal-I/O control list.
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.
1617 Must ensure that all expressions are prepared before being evaluated,
1618 for any whose evaluation might result in the generation of temporaries.
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,
1626 ffeste_io_icilist_ (bool have_err,
1629 ffestvFormat format,
1630 ffestpFile *format_spec)
1632 static tree f2c_icilist_struct = NULL_TREE;
1637 bool constantp = TRUE;
1638 static tree errfield, unitfield, endfield, formatfield, unitlenfield,
1640 tree errinit, unitinit, endinit, formatinit, unitleninit, unitnuminit;
1641 tree unitexp, formatexp, unitlenexp, unitnumexp;
1642 static int mynumber = 0;
1644 if (f2c_icilist_struct == NULL_TREE)
1648 ref = make_node (RECORD_TYPE);
1650 errfield = ffecom_decl_field (ref, NULL_TREE, "err",
1651 ffecom_f2c_flag_type_node);
1652 unitfield = ffecom_decl_field (ref, errfield, "unit",
1654 endfield = ffecom_decl_field (ref, unitfield, "end",
1655 ffecom_f2c_flag_type_node);
1656 formatfield = ffecom_decl_field (ref, endfield, "format",
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);
1663 TYPE_FIELDS (ref) = errfield;
1666 ggc_add_tree_root (&f2c_icilist_struct, 1);
1668 f2c_icilist_struct = ref;
1671 /* Try to do as much compile-time initialization of the structure
1672 as possible, to save run time. */
1674 ffeste_f2c_init_flag_ (have_err, errinit);
1676 unitexp = ffecom_arg_ptr_to_const_expr (unit_expr, &unitlenexp);
1681 unitinit = null_pointer_node;
1685 unitleninit = unitlenexp;
1688 unitleninit = ffecom_integer_zero_node;
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
1696 && TREE_CODE (TREE_TYPE (TREE_TYPE (unitexp))) != ARRAY_TYPE))
1698 /* Not an array, so just one element. */
1699 unitnuminit = ffecom_integer_one_node;
1700 unitnumexp = unitnuminit;
1702 else if (unitexp && unitlenexp)
1704 /* An array, but all the info is constant, so compute now. */
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)
1712 unitnumexp = unitnuminit;
1716 /* Put off computing until run time. */
1717 unitnuminit = ffecom_integer_zero_node;
1718 unitnumexp = NULL_TREE;
1724 case FFESTV_formatNONE:
1725 formatinit = null_pointer_node;
1726 formatexp = formatinit;
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))
1735 formatinit = ffecom_1 (ADDR_EXPR,
1736 build_pointer_type (void_type_node),
1738 TREE_CONSTANT (formatinit) = 1;
1741 case FFESTV_formatCHAREXPR:
1742 ffeste_f2c_init_format_ (formatexp, formatinit, format_spec);
1745 case FFESTV_formatASTERISK:
1746 formatinit = null_pointer_node;
1747 formatexp = formatinit;
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);
1760 assert ("bad format spec" == NULL);
1761 formatinit = ffecom_integer_zero_node;
1762 formatexp = formatinit;
1766 ffeste_f2c_init_flag_ (have_end, endinit);
1768 inits = build_tree_list ((field = TYPE_FIELDS (f2c_icilist_struct)),
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);
1777 inits = build (CONSTRUCTOR, f2c_icilist_struct, NULL_TREE, inits);
1778 TREE_CONSTANT (inits) = constantp ? 1 : 0;
1779 TREE_STATIC (inits) = 1;
1781 t = build_decl (VAR_DECL,
1782 ffecom_get_invented_identifier ("__g77_icilist_%d",
1784 f2c_icilist_struct);
1785 TREE_STATIC (t) = 1;
1786 t = ffecom_start_decl (t, 1);
1787 ffecom_finish_decl (t, inits, 0);
1789 /* Prepare run-time expressions. */
1792 ffecom_prepare_arg_ptr_to_expr (unit_expr);
1794 ffeste_f2c_prepare_format_ (format_spec, formatexp);
1796 ffecom_prepare_end ();
1798 /* Now evaluate run-time expressions as needed. */
1800 if (! unitexp || ! unitlenexp)
1802 int need_unitexp = (! unitexp);
1803 int need_unitlenexp = (! unitlenexp);
1805 unitexp = ffecom_arg_ptr_to_expr (unit_expr, &unitlenexp);
1807 ffeste_f2c_compile_ (unitfield, unitexp);
1808 if (need_unitlenexp)
1809 ffeste_f2c_compile_ (unitlenfield, unitlenexp);
1813 && unitexp != error_mark_node
1814 && unitlenexp != error_mark_node)
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)
1823 ffeste_f2c_compile_ (unitnumfield, unitnumexp);
1826 if (format == FFESTV_formatINTEXPR)
1827 ffeste_f2c_compile_ (formatfield, formatexp);
1829 ffeste_f2c_compile_format_ (formatfield, format_spec, formatexp);
1831 ttype = build_pointer_type (TREE_TYPE (t));
1832 t = ffecom_1 (ADDR_EXPR, ttype, t);
1834 t = build_tree_list (NULL_TREE, t);
1839 /* Make arglist with ptr to INQUIRE control list
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.
1846 Must ensure that all expressions are prepared before being evaluated,
1847 for any whose evaluation might result in the generation of temporaries.
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,
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)
1873 static tree f2c_inquire_struct = NULL_TREE;
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;
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;
1896 if (f2c_inquire_struct == NULL_TREE)
1900 ref = make_node (RECORD_TYPE);
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",
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",
1920 namelenfield = ffecom_decl_field (ref, namefield, "namelen",
1921 ffecom_f2c_ftnlen_type_node);
1922 accessfield = ffecom_decl_field (ref, namelenfield, "access",
1924 accesslenfield = ffecom_decl_field (ref, accessfield, "accesslen",
1925 ffecom_f2c_ftnlen_type_node);
1926 sequentialfield = ffecom_decl_field (ref, accesslenfield, "sequential",
1928 sequentiallenfield = ffecom_decl_field (ref, sequentialfield,
1930 ffecom_f2c_ftnlen_type_node);
1931 directfield = ffecom_decl_field (ref, sequentiallenfield, "direct",
1933 directlenfield = ffecom_decl_field (ref, directfield, "directlen",
1934 ffecom_f2c_ftnlen_type_node);
1935 formfield = ffecom_decl_field (ref, directlenfield, "form",
1937 formlenfield = ffecom_decl_field (ref, formfield, "formlen",
1938 ffecom_f2c_ftnlen_type_node);
1939 formattedfield = ffecom_decl_field (ref, formlenfield, "formatted",
1941 formattedlenfield = ffecom_decl_field (ref, formattedfield,
1943 ffecom_f2c_ftnlen_type_node);
1944 unformattedfield = ffecom_decl_field (ref, formattedlenfield,
1947 unformattedlenfield = ffecom_decl_field (ref, unformattedfield,
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",
1956 blanklenfield = ffecom_decl_field (ref, blankfield, "blanklen",
1957 ffecom_f2c_ftnlen_type_node);
1959 TYPE_FIELDS (ref) = errfield;
1962 ggc_add_tree_root (&f2c_inquire_struct, 1);
1964 f2c_inquire_struct = ref;
1967 /* Try to do as much compile-time initialization of the structure
1968 as possible, to save run time. */
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,
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,
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,
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);
1997 inits = build_tree_list ((field = TYPE_FIELDS (f2c_inquire_struct)),
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);
2026 inits = build (CONSTRUCTOR, f2c_inquire_struct, NULL_TREE, inits);
2027 TREE_CONSTANT (inits) = constantp ? 1 : 0;
2028 TREE_STATIC (inits) = 1;
2030 t = build_decl (VAR_DECL,
2031 ffecom_get_invented_identifier ("__g77_inlist_%d",
2033 f2c_inquire_struct);
2034 TREE_STATIC (t) = 1;
2035 t = ffecom_start_decl (t, 1);
2036 ffecom_finish_decl (t, inits, 0);
2038 /* Prepare run-time expressions. */
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);
2057 ffecom_prepare_end ();
2059 /* Now evaluate run-time expressions as needed. */
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,
2070 ffeste_f2c_compile_char_ (accessfield, accesslenfield, access_spec,
2071 accessexp, accesslenexp);
2072 ffeste_f2c_compile_char_ (sequentialfield, sequentiallenfield,
2073 sequential_spec, sequentialexp,
2075 ffeste_f2c_compile_char_ (directfield, directlenfield, direct_spec,
2076 directexp, directlenexp);
2077 ffeste_f2c_compile_char_ (formfield, formlenfield, form_spec, formexp,
2079 ffeste_f2c_compile_char_ (formattedfield, formattedlenfield, formatted_spec,
2080 formattedexp, formattedlenexp);
2081 ffeste_f2c_compile_char_ (unformattedfield, unformattedlenfield,
2082 unformatted_spec, unformattedexp,
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,
2089 ttype = build_pointer_type (TREE_TYPE (t));
2090 t = ffecom_1 (ADDR_EXPR, ttype, t);
2092 t = build_tree_list (NULL_TREE, t);
2097 /* Make arglist with ptr to OPEN control list
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.
2104 Must ensure that all expressions are prepared before being evaluated,
2105 for any whose evaluation might result in the generation of temporaries.
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,
2113 ffeste_io_olist_ (bool have_err,
2115 ffestpFile *file_spec,
2116 ffestpFile *stat_spec,
2117 ffestpFile *access_spec,
2118 ffestpFile *form_spec,
2119 ffestpFile *recl_spec,
2120 ffestpFile *blank_spec)
2122 static tree f2c_open_struct = NULL_TREE;
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;
2134 unitexp, fileexp, filelenexp, statexp, accessexp, formexp, reclexp,
2136 static int mynumber = 0;
2138 if (f2c_open_struct == NULL_TREE)
2142 ref = make_node (RECORD_TYPE);
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",
2150 filelenfield = ffecom_decl_field (ref, filefield, "filelen",
2151 ffecom_f2c_ftnlen_type_node);
2152 statfield = ffecom_decl_field (ref, filelenfield, "stat",
2154 accessfield = ffecom_decl_field (ref, statfield, "access",
2156 formfield = ffecom_decl_field (ref, accessfield, "form",
2158 reclfield = ffecom_decl_field (ref, formfield, "recl",
2159 ffecom_f2c_ftnint_type_node);
2160 blankfield = ffecom_decl_field (ref, reclfield, "blank",
2163 TYPE_FIELDS (ref) = errfield;
2166 ggc_add_tree_root (&f2c_open_struct, 1);
2168 f2c_open_struct = ref;
2171 /* Try to do as much compile-time initialization of the structure
2172 as possible, to save run time. */
2174 ffeste_f2c_init_flag_ (have_err, errinit);
2176 unitexp = ffecom_const_expr (unit_expr);
2181 unitinit = ffecom_integer_zero_node;
2185 ffeste_f2c_init_char_ (fileexp, fileinit, filelenexp, fileleninit,
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);
2193 inits = build_tree_list ((field = TYPE_FIELDS (f2c_open_struct)), errinit);
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);
2204 inits = build (CONSTRUCTOR, f2c_open_struct, NULL_TREE, inits);
2205 TREE_CONSTANT (inits) = constantp ? 1 : 0;
2206 TREE_STATIC (inits) = 1;
2208 t = build_decl (VAR_DECL,
2209 ffecom_get_invented_identifier ("__g77_olist_%d",
2212 TREE_STATIC (t) = 1;
2213 t = ffecom_start_decl (t, 1);
2214 ffecom_finish_decl (t, inits, 0);
2216 /* Prepare run-time expressions. */
2219 ffecom_prepare_expr (unit_expr);
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);
2228 ffecom_prepare_end ();
2230 /* Now evaluate run-time expressions as needed. */
2234 unitexp = ffecom_expr (unit_expr);
2235 ffeste_f2c_compile_ (unitfield, unitexp);
2238 ffeste_f2c_compile_char_ (filefield, filelenfield, file_spec, fileexp,
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);
2246 ttype = build_pointer_type (TREE_TYPE (t));
2247 t = ffecom_1 (ADDR_EXPR, ttype, t);
2249 t = build_tree_list (NULL_TREE, t);
2254 /* Generate code for BACKSPACE/ENDFILE/REWIND. */
2257 ffeste_subr_beru_ (ffestpBeruStmt *info, ffecomGfrt rt)
2263 ffeste_emit_line_note_ ();
2265 #define specified(something) (info->beru_spec[something].kw_or_val_present)
2267 iostat = specified (FFESTP_beruixIOSTAT);
2268 errl = specified (FFESTP_beruixERR);
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. */
2282 ffeste_start_stmt_ ();
2286 /* Have ERR= specification. */
2290 = ffecom_lookup_label
2291 (info->beru_spec[FFESTP_beruixERR].u.label);
2292 ffeste_io_abort_is_temp_ = FALSE;
2296 /* No ERR= specification. */
2298 ffeste_io_err_ = NULL_TREE;
2300 if ((ffeste_io_abort_is_temp_ = iostat))
2301 ffeste_io_abort_ = ffecom_temp_label ();
2303 ffeste_io_abort_ = NULL_TREE;
2308 /* Have IOSTAT= specification. */
2310 ffeste_io_iostat_is_temp_ = FALSE;
2311 ffeste_io_iostat_ = ffecom_expr
2312 (info->beru_spec[FFESTP_beruixIOSTAT].u.expr);
2314 else if (ffeste_io_abort_ != NULL_TREE)
2316 /* Have no IOSTAT= but have ERR=. */
2318 ffeste_io_iostat_is_temp_ = TRUE;
2320 = ffecom_make_tempvar ("beru", ffecom_integer_type_node,
2321 FFETARGET_charactersizeNONE, -1);
2325 /* No IOSTAT= or ERR= specification. */
2327 ffeste_io_iostat_is_temp_ = FALSE;
2328 ffeste_io_iostat_ = NULL_TREE;
2331 /* Now prescan, then convert, all the arguments. */
2333 alist = ffeste_io_ialist_ (errl || iostat, FFESTV_unitINTEXPR,
2334 info->beru_spec[FFESTP_beruixUNIT].u.expr, 6);
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. */
2339 ffeste_io_call_ (ffecom_call_gfrt (rt, alist, NULL_TREE),
2340 ! ffeste_io_abort_is_temp_);
2342 /* If we've got a temp label, generate its code here. */
2344 if (ffeste_io_abort_is_temp_)
2346 DECL_INITIAL (ffeste_io_abort_) = error_mark_node;
2348 expand_label (ffeste_io_abort_);
2350 assert (ffeste_io_err_ == NULL_TREE);
2353 ffeste_end_stmt_ ();
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. */
2364 ffeste_do (ffestw block)
2366 ffeste_emit_line_note_ ();
2368 if (ffestw_do_tvar (block) == 0)
2370 expand_end_loop (); /* DO WHILE and just DO. */
2372 ffeste_end_block_ (block);
2375 ffeste_end_iterdo_ (block,
2376 ffestw_do_tvar (block),
2377 ffestw_do_incr_saved (block),
2378 ffestw_do_count_var (block));
2381 /* End of statement following logical IF.
2383 Applies to *only* logical IF, not to IF-THEN. */
2388 ffeste_emit_line_note_ ();
2392 ffeste_end_block_ (NULL);
2395 /* Generate "code" for branch label definition. */
2398 ffeste_labeldef_branch (ffelab label)
2402 glabel = ffecom_lookup_label (label);
2403 assert (glabel != NULL_TREE);
2404 if (TREE_CODE (glabel) == ERROR_MARK)
2407 assert (DECL_INITIAL (glabel) == NULL_TREE);
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);
2415 expand_label (glabel);
2418 /* Generate "code" for FORMAT label definition. */
2421 ffeste_labeldef_format (ffelab label)
2423 ffeste_label_formatdef_ = label;
2426 /* Assignment statement (outside of WHERE). */
2429 ffeste_R737A (ffebld dest, ffebld source)
2431 ffeste_check_simple_ ();
2433 ffeste_emit_line_note_ ();
2435 ffeste_start_stmt_ ();
2437 ffecom_expand_let_stmt (dest, source);
2439 ffeste_end_stmt_ ();
2442 /* Block IF (IF-THEN) statement. */
2445 ffeste_R803 (ffestw block, ffebld expr)
2449 ffeste_check_simple_ ();
2451 ffeste_emit_line_note_ ();
2453 ffeste_start_block_ (block);
2455 temp = ffecom_make_tempvar ("ifthen", integer_type_node,
2456 FFETARGET_charactersizeNONE, -1);
2458 ffeste_start_stmt_ ();
2460 ffecom_prepare_expr (expr);
2462 if (ffecom_prepare_end ())
2466 result = ffecom_modify (void_type_node,
2468 ffecom_truth_value (ffecom_expr (expr)));
2470 expand_expr_stmt (result);
2472 ffeste_end_stmt_ ();
2476 ffeste_end_stmt_ ();
2478 temp = ffecom_truth_value (ffecom_expr (expr));
2481 expand_start_cond (temp, 0);
2483 /* No fake `else' constructs introduced (yet). */
2484 ffestw_set_ifthen_fake_else (block, 0);
2487 /* ELSE IF statement. */
2490 ffeste_R804 (ffestw block, ffebld expr)
2494 ffeste_check_simple_ ();
2496 ffeste_emit_line_note_ ();
2498 /* Since ELSEIF(expr) might require preparations for expr,
2499 implement as ELSE; prepare-expr; IF (expr) THEN ...; ENDIF. */
2501 expand_start_else ();
2503 ffeste_start_block_ (block);
2505 temp = ffecom_make_tempvar ("elseif", integer_type_node,
2506 FFETARGET_charactersizeNONE, -1);
2508 ffeste_start_stmt_ ();
2510 ffecom_prepare_expr (expr);
2512 if (ffecom_prepare_end ())
2516 result = ffecom_modify (void_type_node,
2518 ffecom_truth_value (ffecom_expr (expr)));
2520 expand_expr_stmt (result);
2522 ffeste_end_stmt_ ();
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. */
2532 ffeste_end_stmt_ ();
2534 temp = ffecom_truth_value (ffecom_expr (expr));
2537 expand_start_cond (temp, 0);
2539 /* Increment number of fake `else' constructs introduced. */
2540 ffestw_set_ifthen_fake_else (block,
2541 ffestw_ifthen_fake_else (block) + 1);
2544 /* ELSE statement. */
2547 ffeste_R805 (ffestw block UNUSED)
2549 ffeste_check_simple_ ();
2551 ffeste_emit_line_note_ ();
2553 expand_start_else ();
2556 /* END IF statement. */
2559 ffeste_R806 (ffestw block)
2561 int i = ffestw_ifthen_fake_else (block) + 1;
2563 ffeste_emit_line_note_ ();
2569 ffeste_end_block_ (block);
2573 /* Logical IF statement. */
2576 ffeste_R807 (ffebld expr)
2580 ffeste_check_simple_ ();
2582 ffeste_emit_line_note_ ();
2584 ffeste_start_block_ (NULL);
2586 temp = ffecom_make_tempvar ("if", integer_type_node,
2587 FFETARGET_charactersizeNONE, -1);
2589 ffeste_start_stmt_ ();
2591 ffecom_prepare_expr (expr);
2593 if (ffecom_prepare_end ())
2597 result = ffecom_modify (void_type_node,
2599 ffecom_truth_value (ffecom_expr (expr)));
2601 expand_expr_stmt (result);
2603 ffeste_end_stmt_ ();
2607 ffeste_end_stmt_ ();
2609 temp = ffecom_truth_value (ffecom_expr (expr));
2612 expand_start_cond (temp, 0);
2615 /* SELECT CASE statement. */
2618 ffeste_R809 (ffestw block, ffebld expr)
2620 ffeste_check_simple_ ();
2622 ffeste_emit_line_note_ ();
2624 ffeste_start_block_ (block);
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)
2633 /* ~~~Someday handle CHARACTER*1, CHARACTER*N */
2635 /* xgettext:no-c-format */
2636 ffebad_start_msg ("SELECT CASE on CHARACTER type (at %0) not supported -- sorry",
2637 FFEBAD_severityFATAL);
2638 ffebad_here (0, ffestw_line (block), ffestw_col (block));
2640 ffestw_set_select_texpr (block, error_mark_node);
2647 result = ffecom_make_tempvar ("select", ffecom_type_expr (expr),
2648 ffeinfo_size (ffebld_info (expr)),
2651 ffeste_start_stmt_ ();
2653 ffecom_prepare_expr (expr);
2655 ffecom_prepare_end ();
2657 texpr = ffecom_expr (expr);
2659 assert (TYPE_MAIN_VARIANT (TREE_TYPE (texpr))
2660 == TYPE_MAIN_VARIANT (TREE_TYPE (result)));
2662 texpr = ffecom_modify (void_type_node,
2665 expand_expr_stmt (texpr);
2667 ffeste_end_stmt_ ();
2669 expand_start_case (1, result, TREE_TYPE (result),
2670 "SELECT CASE statement");
2671 ffestw_set_select_texpr (block, texpr);
2672 ffestw_set_select_break (block, FALSE);
2678 If casenum is 0, it's CASE DEFAULT. Else it's the case ranges at
2679 the start of the first_stmt list in the select object at the top of
2680 the stack that match casenum. */
2683 ffeste_R810 (ffestw block, unsigned long casenum)
2685 ffestwSelect s = ffestw_select (block);
2693 ffeste_check_simple_ ();
2695 if (s->first_stmt == (ffestwCase) &s->first_rel)
2700 ffeste_emit_line_note_ ();
2702 if (ffestw_select_texpr (block) == error_mark_node)
2705 /* ~~~Someday handle CHARACTER*1, CHARACTER*N */
2707 tlabel = build_decl (LABEL_DECL, NULL_TREE, NULL_TREE);
2709 if (ffestw_select_break (block))
2710 expand_exit_something ();
2712 ffestw_set_select_break (block, TRUE);
2714 if ((c == NULL) || (casenum != c->casenum))
2716 if (casenum == 0) /* Intentional CASE DEFAULT. */
2718 pushok = pushcase (NULL_TREE, 0, tlabel, &duplicate);
2719 assert (pushok == 0);
2725 texprlow = (c->low == NULL) ? NULL_TREE
2726 : ffecom_constantunion (&ffebld_constant_union (c->low), s->type,
2728 ffecom_tree_type[s->type][s->kindtype]);
2729 if (c->low != c->high)
2731 texprhigh = (c->high == NULL) ? NULL_TREE
2732 : ffecom_constantunion (&ffebld_constant_union (c->high),
2733 s->type, s->kindtype,
2734 ffecom_tree_type[s->type][s->kindtype]);
2735 pushok = pushcase_range (texprlow, texprhigh, convert,
2736 tlabel, &duplicate);
2739 pushok = pushcase (texprlow, convert, tlabel, &duplicate);
2740 assert (pushok == 0);
2743 c->previous_stmt->previous_stmt->next_stmt = c;
2744 c->previous_stmt = c->previous_stmt->previous_stmt;
2746 while ((c != (ffestwCase) &s->first_rel) && (casenum == c->casenum));
2749 /* END SELECT statement. */
2752 ffeste_R811 (ffestw block)
2754 ffeste_emit_line_note_ ();
2756 /* ~~~Someday handle CHARACTER*1, CHARACTER*N */
2758 if (TREE_CODE (ffestw_select_texpr (block)) != ERROR_MARK)
2759 expand_end_case (ffestw_select_texpr (block));
2761 ffeste_end_block_ (block);
2764 /* Iterative DO statement. */
2767 ffeste_R819A (ffestw block, ffelab label UNUSED, ffebld var,
2768 ffebld start, ffelexToken start_token,
2769 ffebld end, ffelexToken end_token,
2770 ffebld incr, ffelexToken incr_token)
2772 ffeste_check_simple_ ();
2774 ffeste_emit_line_note_ ();
2776 ffeste_begin_iterdo_ (block, NULL, NULL, NULL,
2781 "Iterative DO loop");
2784 /* DO WHILE statement. */
2787 ffeste_R819B (ffestw block, ffelab label UNUSED, ffebld expr)
2791 ffeste_check_simple_ ();
2793 ffeste_emit_line_note_ ();
2795 ffeste_start_block_ (block);
2799 struct nesting *loop;
2802 result = ffecom_make_tempvar ("dowhile", integer_type_node,
2803 FFETARGET_charactersizeNONE, -1);
2804 loop = expand_start_loop (1);
2806 ffeste_start_stmt_ ();
2808 ffecom_prepare_expr (expr);
2810 ffecom_prepare_end ();
2812 mod = ffecom_modify (void_type_node,
2814 ffecom_truth_value (ffecom_expr (expr)));
2815 expand_expr_stmt (mod);
2817 ffeste_end_stmt_ ();
2819 ffestw_set_do_hook (block, loop);
2820 expand_exit_loop_top_cond (0, result);
2823 ffestw_set_do_hook (block, expand_start_loop (1));
2825 ffestw_set_do_tvar (block, NULL_TREE);
2828 /* END DO statement.
2830 This is the MIL-STD 1753 END DO. It's syntactic sugar, similar to
2831 CONTINUE (except that it has to have a label that is the target of
2832 one or more iterative DO statement), not the Fortran-90 structured
2833 END DO, which is handled elsewhere, as is the actual mechanism of
2834 ending an iterative DO statement, even one that ends at a label. */
2839 ffeste_check_simple_ ();
2841 ffeste_emit_line_note_ ();
2846 /* CYCLE statement. */
2849 ffeste_R834 (ffestw block)
2851 ffeste_check_simple_ ();
2853 ffeste_emit_line_note_ ();
2855 expand_continue_loop (ffestw_do_hook (block));
2858 /* EXIT statement. */
2861 ffeste_R835 (ffestw block)
2863 ffeste_check_simple_ ();
2865 ffeste_emit_line_note_ ();
2867 expand_exit_loop (ffestw_do_hook (block));
2870 /* GOTO statement. */
2873 ffeste_R836 (ffelab label)
2877 ffeste_check_simple_ ();
2879 ffeste_emit_line_note_ ();
2881 glabel = ffecom_lookup_label (label);
2882 if ((glabel != NULL_TREE)
2883 && (TREE_CODE (glabel) != ERROR_MARK))
2885 expand_goto (glabel);
2886 TREE_USED (glabel) = 1;
2890 /* Computed GOTO statement. */
2893 ffeste_R837 (ffelab *labels, int count, ffebld expr)
2902 ffeste_check_simple_ ();
2904 ffeste_emit_line_note_ ();
2906 ffeste_start_stmt_ ();
2908 ffecom_prepare_expr (expr);
2910 ffecom_prepare_end ();
2912 texpr = ffecom_expr (expr);
2914 expand_start_case (0, texpr, TREE_TYPE (texpr), "computed GOTO statement");
2916 for (i = 0; i < count; ++i)
2918 value = build_int_2 (i + 1, 0);
2919 tlabel = build_decl (LABEL_DECL, NULL_TREE, NULL_TREE);
2921 pushok = pushcase (value, convert, tlabel, &duplicate);
2922 assert (pushok == 0);
2924 tlabel = ffecom_lookup_label (labels[i]);
2925 if ((tlabel == NULL_TREE)
2926 || (TREE_CODE (tlabel) == ERROR_MARK))
2929 expand_goto (tlabel);
2930 TREE_USED (tlabel) = 1;
2932 expand_end_case (texpr);
2934 ffeste_end_stmt_ ();
2937 /* ASSIGN statement. */
2940 ffeste_R838 (ffelab label, ffebld target)
2946 ffeste_check_simple_ ();
2948 ffeste_emit_line_note_ ();
2950 /* No need to call ffeste_start_stmt_(), as the sorts of expressions
2951 seen here should never require use of temporaries. */
2953 label_tree = ffecom_lookup_label (label);
2954 if ((label_tree != NULL_TREE)
2955 && (TREE_CODE (label_tree) != ERROR_MARK))
2957 label_tree = ffecom_1 (ADDR_EXPR,
2958 build_pointer_type (void_type_node),
2960 TREE_CONSTANT (label_tree) = 1;
2962 target_tree = ffecom_expr_assign_w (target);
2963 if (GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (target_tree)))
2964 < GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (label_tree))))
2965 error ("ASSIGN to variable that is too small");
2967 label_tree = convert (TREE_TYPE (target_tree), label_tree);
2969 expr_tree = ffecom_modify (void_type_node,
2972 expand_expr_stmt (expr_tree);
2976 /* Assigned GOTO statement. */
2979 ffeste_R839 (ffebld target)
2983 ffeste_check_simple_ ();
2985 ffeste_emit_line_note_ ();
2987 /* No need to call ffeste_start_stmt_(), as the sorts of expressions
2988 seen here should never require use of temporaries. */
2990 t = ffecom_expr_assign (target);
2991 if (GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (t)))
2992 < GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node))))
2993 error ("ASSIGNed GOTO target variable is too small");
2995 expand_computed_goto (convert (TREE_TYPE (null_pointer_node), t));
2998 /* Arithmetic IF statement. */
3001 ffeste_R840 (ffebld expr, ffelab neg, ffelab zero, ffelab pos)
3003 tree gneg = ffecom_lookup_label (neg);
3004 tree gzero = ffecom_lookup_label (zero);
3005 tree gpos = ffecom_lookup_label (pos);
3008 ffeste_check_simple_ ();
3010 ffeste_emit_line_note_ ();
3012 if ((gneg == NULL_TREE) || (gzero == NULL_TREE) || (gpos == NULL_TREE))
3014 if ((TREE_CODE (gneg) == ERROR_MARK)
3015 || (TREE_CODE (gzero) == ERROR_MARK)
3016 || (TREE_CODE (gpos) == ERROR_MARK))
3019 ffeste_start_stmt_ ();
3021 ffecom_prepare_expr (expr);
3023 ffecom_prepare_end ();
3028 expand_goto (gzero);
3031 /* IF (expr.LE.0) THEN GOTO neg/zero ELSE GOTO pos. */
3032 texpr = ffecom_expr (expr);
3033 texpr = ffecom_2 (LE_EXPR, integer_type_node,
3035 convert (TREE_TYPE (texpr),
3036 integer_zero_node));
3037 expand_start_cond (ffecom_truth_value (texpr), 0);
3038 expand_goto (gzero);
3039 expand_start_else ();
3044 else if (neg == pos)
3046 /* IF (expr.NE.0) THEN GOTO neg/pos ELSE GOTO zero. */
3047 texpr = ffecom_expr (expr);
3048 texpr = ffecom_2 (NE_EXPR, integer_type_node,
3050 convert (TREE_TYPE (texpr),
3051 integer_zero_node));
3052 expand_start_cond (ffecom_truth_value (texpr), 0);
3054 expand_start_else ();
3055 expand_goto (gzero);
3058 else if (zero == pos)
3060 /* IF (expr.GE.0) THEN GOTO zero/pos ELSE GOTO neg. */
3061 texpr = ffecom_expr (expr);
3062 texpr = ffecom_2 (GE_EXPR, integer_type_node,
3064 convert (TREE_TYPE (texpr),
3065 integer_zero_node));
3066 expand_start_cond (ffecom_truth_value (texpr), 0);
3067 expand_goto (gzero);
3068 expand_start_else ();
3074 /* Use a SAVE_EXPR in combo with:
3075 IF (expr.LT.0) THEN GOTO neg
3076 ELSEIF (expr.GT.0) THEN GOTO pos
3078 tree expr_saved = ffecom_save_tree (ffecom_expr (expr));
3080 texpr = ffecom_2 (LT_EXPR, integer_type_node,
3082 convert (TREE_TYPE (expr_saved),
3083 integer_zero_node));
3084 expand_start_cond (ffecom_truth_value (texpr), 0);
3086 texpr = ffecom_2 (GT_EXPR, integer_type_node,
3088 convert (TREE_TYPE (expr_saved),
3089 integer_zero_node));
3090 expand_start_elseif (ffecom_truth_value (texpr));
3092 expand_start_else ();
3093 expand_goto (gzero);
3097 ffeste_end_stmt_ ();
3100 /* CONTINUE statement. */
3105 ffeste_check_simple_ ();
3107 ffeste_emit_line_note_ ();
3112 /* STOP statement. */
3115 ffeste_R842 (ffebld expr)
3120 ffeste_check_simple_ ();
3122 ffeste_emit_line_note_ ();
3125 || (ffeinfo_basictype (ffebld_info (expr))
3126 == FFEINFO_basictypeANY))
3128 msg = ffelex_token_new_character ("",
3129 ffelex_token_where_line (ffesta_tokens[0]),
3130 ffelex_token_where_column (ffesta_tokens[0]));
3131 expr = ffebld_new_conter (ffebld_constant_new_characterdefault
3133 ffelex_token_kill (msg);
3134 ffebld_set_info (expr, ffeinfo_new (FFEINFO_basictypeCHARACTER,
3135 FFEINFO_kindtypeCHARACTERDEFAULT,
3136 0, FFEINFO_kindENTITY,
3137 FFEINFO_whereCONSTANT, 0));
3139 else if (ffeinfo_basictype (ffebld_info (expr))
3140 == FFEINFO_basictypeINTEGER)
3144 assert (ffebld_op (expr) == FFEBLD_opCONTER);
3145 assert (ffeinfo_kindtype (ffebld_info (expr))
3146 == FFEINFO_kindtypeINTEGERDEFAULT);
3147 sprintf (num, "%" ffetargetIntegerDefault_f "d",
3148 ffebld_constant_integer1 (ffebld_conter (expr)));
3149 msg = ffelex_token_new_character (num,
3150 ffelex_token_where_line (ffesta_tokens[0]),
3151 ffelex_token_where_column (ffesta_tokens[0]));
3152 expr = ffebld_new_conter (ffebld_constant_new_characterdefault (msg));
3153 ffelex_token_kill (msg);
3154 ffebld_set_info (expr, ffeinfo_new (FFEINFO_basictypeCHARACTER,
3155 FFEINFO_kindtypeCHARACTERDEFAULT,
3156 0, FFEINFO_kindENTITY,
3157 FFEINFO_whereCONSTANT, 0));
3161 assert (ffeinfo_basictype (ffebld_info (expr))
3162 == FFEINFO_basictypeCHARACTER);
3163 assert (ffebld_op (expr) == FFEBLD_opCONTER);
3164 assert (ffeinfo_kindtype (ffebld_info (expr))
3165 == FFEINFO_kindtypeCHARACTERDEFAULT);
3168 /* No need to call ffeste_start_stmt_(), as the sorts of expressions
3169 seen here should never require use of temporaries. */
3171 callit = ffecom_call_gfrt (FFECOM_gfrtSTOP,
3172 ffecom_list_ptr_to_expr (ffebld_new_item (expr, NULL)),
3174 TREE_SIDE_EFFECTS (callit) = 1;
3176 expand_expr_stmt (callit);
3179 /* PAUSE statement. */
3182 ffeste_R843 (ffebld expr)
3187 ffeste_check_simple_ ();
3189 ffeste_emit_line_note_ ();
3192 || (ffeinfo_basictype (ffebld_info (expr))
3193 == FFEINFO_basictypeANY))
3195 msg = ffelex_token_new_character ("",
3196 ffelex_token_where_line (ffesta_tokens[0]),
3197 ffelex_token_where_column (ffesta_tokens[0]));
3198 expr = ffebld_new_conter (ffebld_constant_new_characterdefault (msg));
3199 ffelex_token_kill (msg);
3200 ffebld_set_info (expr, ffeinfo_new (FFEINFO_basictypeCHARACTER,
3201 FFEINFO_kindtypeCHARACTERDEFAULT,
3202 0, FFEINFO_kindENTITY,
3203 FFEINFO_whereCONSTANT, 0));
3205 else if (ffeinfo_basictype (ffebld_info (expr)) == FFEINFO_basictypeINTEGER)
3209 assert (ffebld_op (expr) == FFEBLD_opCONTER);
3210 assert (ffeinfo_kindtype (ffebld_info (expr))
3211 == FFEINFO_kindtypeINTEGERDEFAULT);
3212 sprintf (num, "%" ffetargetIntegerDefault_f "d",
3213 ffebld_constant_integer1 (ffebld_conter (expr)));
3214 msg = ffelex_token_new_character (num, ffelex_token_where_line (ffesta_tokens[0]),
3215 ffelex_token_where_column (ffesta_tokens[0]));
3216 expr = ffebld_new_conter (ffebld_constant_new_characterdefault (msg));
3217 ffelex_token_kill (msg);
3218 ffebld_set_info (expr, ffeinfo_new (FFEINFO_basictypeCHARACTER,
3219 FFEINFO_kindtypeCHARACTERDEFAULT,
3220 0, FFEINFO_kindENTITY,
3221 FFEINFO_whereCONSTANT, 0));
3225 assert (ffeinfo_basictype (ffebld_info (expr))
3226 == FFEINFO_basictypeCHARACTER);
3227 assert (ffebld_op (expr) == FFEBLD_opCONTER);
3228 assert (ffeinfo_kindtype (ffebld_info (expr))
3229 == FFEINFO_kindtypeCHARACTERDEFAULT);
3232 /* No need to call ffeste_start_stmt_(), as the sorts of expressions
3233 seen here should never require use of temporaries. */
3235 callit = ffecom_call_gfrt (FFECOM_gfrtPAUSE,
3236 ffecom_list_ptr_to_expr (ffebld_new_item (expr, NULL)),
3238 TREE_SIDE_EFFECTS (callit) = 1;
3240 expand_expr_stmt (callit);
3243 /* OPEN statement. */
3246 ffeste_R904 (ffestpOpenStmt *info)
3252 ffeste_check_simple_ ();
3254 ffeste_emit_line_note_ ();
3256 #define specified(something) (info->open_spec[something].kw_or_val_present)
3258 iostat = specified (FFESTP_openixIOSTAT);
3259 errl = specified (FFESTP_openixERR);
3263 ffeste_start_stmt_ ();
3269 = ffecom_lookup_label
3270 (info->open_spec[FFESTP_openixERR].u.label);
3271 ffeste_io_abort_is_temp_ = FALSE;
3275 ffeste_io_err_ = NULL_TREE;
3277 if ((ffeste_io_abort_is_temp_ = iostat))
3278 ffeste_io_abort_ = ffecom_temp_label ();
3280 ffeste_io_abort_ = NULL_TREE;
3285 /* Have IOSTAT= specification. */
3287 ffeste_io_iostat_is_temp_ = FALSE;
3288 ffeste_io_iostat_ = ffecom_expr
3289 (info->open_spec[FFESTP_openixIOSTAT].u.expr);
3291 else if (ffeste_io_abort_ != NULL_TREE)
3293 /* Have no IOSTAT= but have ERR=. */
3295 ffeste_io_iostat_is_temp_ = TRUE;
3297 = ffecom_make_tempvar ("open", ffecom_integer_type_node,
3298 FFETARGET_charactersizeNONE, -1);
3302 /* No IOSTAT= or ERR= specification. */
3304 ffeste_io_iostat_is_temp_ = FALSE;
3305 ffeste_io_iostat_ = NULL_TREE;
3308 /* Now prescan, then convert, all the arguments. */
3310 args = ffeste_io_olist_ (errl || iostat,
3311 info->open_spec[FFESTP_openixUNIT].u.expr,
3312 &info->open_spec[FFESTP_openixFILE],
3313 &info->open_spec[FFESTP_openixSTATUS],
3314 &info->open_spec[FFESTP_openixACCESS],
3315 &info->open_spec[FFESTP_openixFORM],
3316 &info->open_spec[FFESTP_openixRECL],
3317 &info->open_spec[FFESTP_openixBLANK]);
3319 /* Don't generate "if (iostat != 0) goto label;" if label is temp abort
3320 label, since we're gonna fall through to there anyway. */
3322 ffeste_io_call_ (ffecom_call_gfrt (FFECOM_gfrtFOPEN, args, NULL_TREE),
3323 ! ffeste_io_abort_is_temp_);
3325 /* If we've got a temp label, generate its code here. */
3327 if (ffeste_io_abort_is_temp_)
3329 DECL_INITIAL (ffeste_io_abort_) = error_mark_node;
3331 expand_label (ffeste_io_abort_);
3333 assert (ffeste_io_err_ == NULL_TREE);
3336 ffeste_end_stmt_ ();
3339 /* CLOSE statement. */
3342 ffeste_R907 (ffestpCloseStmt *info)
3348 ffeste_check_simple_ ();
3350 ffeste_emit_line_note_ ();
3352 #define specified(something) (info->close_spec[something].kw_or_val_present)
3354 iostat = specified (FFESTP_closeixIOSTAT);
3355 errl = specified (FFESTP_closeixERR);
3359 ffeste_start_stmt_ ();
3365 = ffecom_lookup_label
3366 (info->close_spec[FFESTP_closeixERR].u.label);
3367 ffeste_io_abort_is_temp_ = FALSE;
3371 ffeste_io_err_ = NULL_TREE;
3373 if ((ffeste_io_abort_is_temp_ = iostat))
3374 ffeste_io_abort_ = ffecom_temp_label ();
3376 ffeste_io_abort_ = NULL_TREE;
3381 /* Have IOSTAT= specification. */
3383 ffeste_io_iostat_is_temp_ = FALSE;
3384 ffeste_io_iostat_ = ffecom_expr
3385 (info->close_spec[FFESTP_closeixIOSTAT].u.expr);
3387 else if (ffeste_io_abort_ != NULL_TREE)
3389 /* Have no IOSTAT= but have ERR=. */
3391 ffeste_io_iostat_is_temp_ = TRUE;
3393 = ffecom_make_tempvar ("close", ffecom_integer_type_node,
3394 FFETARGET_charactersizeNONE, -1);
3398 /* No IOSTAT= or ERR= specification. */
3400 ffeste_io_iostat_is_temp_ = FALSE;
3401 ffeste_io_iostat_ = NULL_TREE;
3404 /* Now prescan, then convert, all the arguments. */
3406 args = ffeste_io_cllist_ (errl || iostat,
3407 info->close_spec[FFESTP_closeixUNIT].u.expr,
3408 &info->close_spec[FFESTP_closeixSTATUS]);
3410 /* Don't generate "if (iostat != 0) goto label;" if label is temp abort
3411 label, since we're gonna fall through to there anyway. */
3413 ffeste_io_call_ (ffecom_call_gfrt (FFECOM_gfrtFCLOS, args, NULL_TREE),
3414 ! ffeste_io_abort_is_temp_);
3416 /* If we've got a temp label, generate its code here. */
3418 if (ffeste_io_abort_is_temp_)
3420 DECL_INITIAL (ffeste_io_abort_) = error_mark_node;
3422 expand_label (ffeste_io_abort_);
3424 assert (ffeste_io_err_ == NULL_TREE);
3427 ffeste_end_stmt_ ();
3430 /* READ(...) statement -- start. */
3433 ffeste_R909_start (ffestpReadStmt *info, bool only_format UNUSED,
3434 ffestvUnit unit, ffestvFormat format, bool rec,
3444 ffeste_check_start_ ();
3446 ffeste_emit_line_note_ ();
3448 /* First determine the start, per-item, and end run-time functions to
3449 call. The per-item function is picked by choosing an ffeste function
3450 to call to handle a given item; it knows how to generate a call to the
3451 appropriate run-time function, and is called an "I/O driver". */
3455 case FFESTV_formatNONE: /* no FMT= */
3456 ffeste_io_driver_ = ffeste_io_douio_;
3458 start = FFECOM_gfrtSRDUE, end = FFECOM_gfrtERDUE;
3460 start = FFECOM_gfrtSRSUE, end = FFECOM_gfrtERSUE;
3463 case FFESTV_formatLABEL: /* FMT=10 */
3464 case FFESTV_formatCHAREXPR: /* FMT='(I10)' */
3465 case FFESTV_formatINTEXPR: /* FMT=I [after ASSIGN 10 TO I] */
3466 ffeste_io_driver_ = ffeste_io_dofio_;
3468 start = FFECOM_gfrtSRDFE, end = FFECOM_gfrtERDFE;
3469 else if (unit == FFESTV_unitCHAREXPR)
3470 start = FFECOM_gfrtSRSFI, end = FFECOM_gfrtERSFI;
3472 start = FFECOM_gfrtSRSFE, end = FFECOM_gfrtERSFE;
3475 case FFESTV_formatASTERISK: /* FMT=* */
3476 ffeste_io_driver_ = ffeste_io_dolio_;
3477 if (unit == FFESTV_unitCHAREXPR)
3478 start = FFECOM_gfrtSRSLI, end = FFECOM_gfrtERSLI;
3480 start = FFECOM_gfrtSRSLE, end = FFECOM_gfrtERSLE;
3483 case FFESTV_formatNAMELIST: /* FMT=FOO or NML=FOO [NAMELIST
3485 ffeste_io_driver_ = NULL; /* No start or driver function. */
3486 start = FFECOM_gfrtSRSNE, end = FFECOM_gfrt;
3490 assert ("Weird stuff" == NULL);
3491 start = FFECOM_gfrt, end = FFECOM_gfrt;
3494 ffeste_io_endgfrt_ = end;
3496 #define specified(something) (info->read_spec[something].kw_or_val_present)
3498 iostat = specified (FFESTP_readixIOSTAT);
3499 errl = specified (FFESTP_readixERR);
3500 endl = specified (FFESTP_readixEND);
3504 ffeste_start_stmt_ ();
3508 /* Have ERR= specification. */
3511 = ffecom_lookup_label (info->read_spec[FFESTP_readixERR].u.label);
3515 /* Have both ERR= and END=. Need a temp label to handle both. */
3517 = ffecom_lookup_label (info->read_spec[FFESTP_readixEND].u.label);
3518 ffeste_io_abort_is_temp_ = TRUE;
3519 ffeste_io_abort_ = ffecom_temp_label ();
3523 /* Have ERR= but no END=. */
3524 ffeste_io_end_ = NULL_TREE;
3525 if ((ffeste_io_abort_is_temp_ = iostat))
3526 ffeste_io_abort_ = ffecom_temp_label ();
3528 ffeste_io_abort_ = ffeste_io_err_;
3533 /* No ERR= specification. */
3535 ffeste_io_err_ = NULL_TREE;
3538 /* Have END= but no ERR=. */
3540 = ffecom_lookup_label (info->read_spec[FFESTP_readixEND].u.label);
3541 if ((ffeste_io_abort_is_temp_ = iostat))
3542 ffeste_io_abort_ = ffecom_temp_label ();
3544 ffeste_io_abort_ = ffeste_io_end_;
3548 /* Have no ERR= or END=. */
3550 ffeste_io_end_ = NULL_TREE;
3551 if ((ffeste_io_abort_is_temp_ = iostat))
3552 ffeste_io_abort_ = ffecom_temp_label ();
3554 ffeste_io_abort_ = NULL_TREE;
3560 /* Have IOSTAT= specification. */
3562 ffeste_io_iostat_is_temp_ = FALSE;
3564 = ffecom_expr (info->read_spec[FFESTP_readixIOSTAT].u.expr);
3566 else if (ffeste_io_abort_ != NULL_TREE)
3568 /* Have no IOSTAT= but have ERR= and/or END=. */
3570 ffeste_io_iostat_is_temp_ = TRUE;
3572 = ffecom_make_tempvar ("read", ffecom_integer_type_node,
3573 FFETARGET_charactersizeNONE, -1);
3577 /* No IOSTAT=, ERR=, or END= specification. */
3579 ffeste_io_iostat_is_temp_ = FALSE;
3580 ffeste_io_iostat_ = NULL_TREE;
3583 /* Now prescan, then convert, all the arguments. */
3585 if (unit == FFESTV_unitCHAREXPR)
3586 cilist = ffeste_io_icilist_ (errl || iostat,
3587 info->read_spec[FFESTP_readixUNIT].u.expr,
3588 endl || iostat, format,
3589 &info->read_spec[FFESTP_readixFORMAT]);
3591 cilist = ffeste_io_cilist_ (errl || iostat, unit,
3592 info->read_spec[FFESTP_readixUNIT].u.expr,
3593 5, endl || iostat, format,
3594 &info->read_spec[FFESTP_readixFORMAT],
3596 info->read_spec[FFESTP_readixREC].u.expr);
3598 /* If there is no end function, then there are no item functions (i.e.
3599 it's a NAMELIST), and vice versa by the way. In this situation, don't
3600 generate the "if (iostat != 0) goto label;" if the label is temp abort
3601 label, since we're gonna fall through to there anyway. */
3603 ffeste_io_call_ (ffecom_call_gfrt (start, cilist, NULL_TREE),
3604 (! ffeste_io_abort_is_temp_) || (end != FFECOM_gfrt));
3607 /* READ statement -- I/O item. */
3610 ffeste_R909_item (ffebld expr, ffelexToken expr_token)
3612 ffeste_check_item_ ();
3617 /* Strip parens off items such as in "READ *,(A)". This is really a bug
3618 in the user's code, but I've been told lots of code does this. */
3619 while (ffebld_op (expr) == FFEBLD_opPAREN)
3620 expr = ffebld_left (expr);
3622 if (ffebld_op (expr) == FFEBLD_opANY)
3625 if (ffebld_op (expr) == FFEBLD_opIMPDO)
3626 ffeste_io_impdo_ (expr, expr_token);
3629 ffeste_start_stmt_ ();
3631 ffecom_prepare_arg_ptr_to_expr (expr);
3633 ffecom_prepare_end ();
3635 ffeste_io_call_ ((*ffeste_io_driver_) (expr), TRUE);
3637 ffeste_end_stmt_ ();
3641 /* READ statement -- end. */
3644 ffeste_R909_finish ()
3646 ffeste_check_finish_ ();
3648 /* Don't generate "if (iostat != 0) goto label;" if label is temp abort
3649 label, since we're gonna fall through to there anyway. */
3651 if (ffeste_io_endgfrt_ != FFECOM_gfrt)
3652 ffeste_io_call_ (ffecom_call_gfrt (ffeste_io_endgfrt_, NULL_TREE,
3654 ! ffeste_io_abort_is_temp_);
3656 /* If we've got a temp label, generate its code here and have it fan out
3657 to the END= or ERR= label as appropriate. */
3659 if (ffeste_io_abort_is_temp_)
3661 DECL_INITIAL (ffeste_io_abort_) = error_mark_node;
3663 expand_label (ffeste_io_abort_);
3665 /* "if (iostat<0) goto end_label;". */
3667 if ((ffeste_io_end_ != NULL_TREE)
3668 && (TREE_CODE (ffeste_io_end_) != ERROR_MARK))
3670 expand_start_cond (ffecom_truth_value
3671 (ffecom_2 (LT_EXPR, integer_type_node,
3673 ffecom_integer_zero_node)),
3675 expand_goto (ffeste_io_end_);
3679 /* "if (iostat>0) goto err_label;". */
3681 if ((ffeste_io_err_ != NULL_TREE)
3682 && (TREE_CODE (ffeste_io_err_) != ERROR_MARK))
3684 expand_start_cond (ffecom_truth_value
3685 (ffecom_2 (GT_EXPR, integer_type_node,
3687 ffecom_integer_zero_node)),
3689 expand_goto (ffeste_io_err_);
3694 ffeste_end_stmt_ ();
3697 /* WRITE statement -- start. */
3700 ffeste_R910_start (ffestpWriteStmt *info, ffestvUnit unit,
3701 ffestvFormat format, bool rec)
3709 ffeste_check_start_ ();
3711 ffeste_emit_line_note_ ();
3713 /* First determine the start, per-item, and end run-time functions to
3714 call. The per-item function is picked by choosing an ffeste function
3715 to call to handle a given item; it knows how to generate a call to the
3716 appropriate run-time function, and is called an "I/O driver". */
3720 case FFESTV_formatNONE: /* no FMT= */
3721 ffeste_io_driver_ = ffeste_io_douio_;
3723 start = FFECOM_gfrtSWDUE, end = FFECOM_gfrtEWDUE;
3725 start = FFECOM_gfrtSWSUE, end = FFECOM_gfrtEWSUE;
3728 case FFESTV_formatLABEL: /* FMT=10 */
3729 case FFESTV_formatCHAREXPR: /* FMT='(I10)' */
3730 case FFESTV_formatINTEXPR: /* FMT=I [after ASSIGN 10 TO I] */
3731 ffeste_io_driver_ = ffeste_io_dofio_;
3733 start = FFECOM_gfrtSWDFE, end = FFECOM_gfrtEWDFE;
3734 else if (unit == FFESTV_unitCHAREXPR)
3735 start = FFECOM_gfrtSWSFI, end = FFECOM_gfrtEWSFI;
3737 start = FFECOM_gfrtSWSFE, end = FFECOM_gfrtEWSFE;
3740 case FFESTV_formatASTERISK: /* FMT=* */
3741 ffeste_io_driver_ = ffeste_io_dolio_;
3742 if (unit == FFESTV_unitCHAREXPR)
3743 start = FFECOM_gfrtSWSLI, end = FFECOM_gfrtEWSLI;
3745 start = FFECOM_gfrtSWSLE, end = FFECOM_gfrtEWSLE;
3748 case FFESTV_formatNAMELIST: /* FMT=FOO or NML=FOO [NAMELIST
3750 ffeste_io_driver_ = NULL; /* No start or driver function. */
3751 start = FFECOM_gfrtSWSNE, end = FFECOM_gfrt;
3755 assert ("Weird stuff" == NULL);
3756 start = FFECOM_gfrt, end = FFECOM_gfrt;
3759 ffeste_io_endgfrt_ = end;
3761 #define specified(something) (info->write_spec[something].kw_or_val_present)
3763 iostat = specified (FFESTP_writeixIOSTAT);
3764 errl = specified (FFESTP_writeixERR);
3768 ffeste_start_stmt_ ();
3770 ffeste_io_end_ = NULL_TREE;
3774 /* Have ERR= specification. */
3778 = ffecom_lookup_label
3779 (info->write_spec[FFESTP_writeixERR].u.label);
3780 ffeste_io_abort_is_temp_ = FALSE;
3784 /* No ERR= specification. */
3786 ffeste_io_err_ = NULL_TREE;
3788 if ((ffeste_io_abort_is_temp_ = iostat))
3789 ffeste_io_abort_ = ffecom_temp_label ();
3791 ffeste_io_abort_ = NULL_TREE;
3796 /* Have IOSTAT= specification. */
3798 ffeste_io_iostat_is_temp_ = FALSE;
3799 ffeste_io_iostat_ = ffecom_expr
3800 (info->write_spec[FFESTP_writeixIOSTAT].u.expr);
3802 else if (ffeste_io_abort_ != NULL_TREE)
3804 /* Have no IOSTAT= but have ERR=. */
3806 ffeste_io_iostat_is_temp_ = TRUE;
3808 = ffecom_make_tempvar ("write", ffecom_integer_type_node,
3809 FFETARGET_charactersizeNONE, -1);
3813 /* No IOSTAT= or ERR= specification. */
3815 ffeste_io_iostat_is_temp_ = FALSE;
3816 ffeste_io_iostat_ = NULL_TREE;
3819 /* Now prescan, then convert, all the arguments. */
3821 if (unit == FFESTV_unitCHAREXPR)
3822 cilist = ffeste_io_icilist_ (errl || iostat,
3823 info->write_spec[FFESTP_writeixUNIT].u.expr,
3825 &info->write_spec[FFESTP_writeixFORMAT]);
3827 cilist = ffeste_io_cilist_ (errl || iostat, unit,
3828 info->write_spec[FFESTP_writeixUNIT].u.expr,
3830 &info->write_spec[FFESTP_writeixFORMAT],
3832 info->write_spec[FFESTP_writeixREC].u.expr);
3834 /* If there is no end function, then there are no item functions (i.e.
3835 it's a NAMELIST), and vice versa by the way. In this situation, don't
3836 generate the "if (iostat != 0) goto label;" if the label is temp abort
3837 label, since we're gonna fall through to there anyway. */
3839 ffeste_io_call_ (ffecom_call_gfrt (start, cilist, NULL_TREE),
3840 (! ffeste_io_abort_is_temp_) || (end != FFECOM_gfrt));
3843 /* WRITE statement -- I/O item. */
3846 ffeste_R910_item (ffebld expr, ffelexToken expr_token)
3848 ffeste_check_item_ ();
3853 if (ffebld_op (expr) == FFEBLD_opANY)
3856 if (ffebld_op (expr) == FFEBLD_opIMPDO)
3857 ffeste_io_impdo_ (expr, expr_token);
3860 ffeste_start_stmt_ ();
3862 ffecom_prepare_arg_ptr_to_expr (expr);
3864 ffecom_prepare_end ();
3866 ffeste_io_call_ ((*ffeste_io_driver_) (expr), TRUE);
3868 ffeste_end_stmt_ ();
3872 /* WRITE statement -- end. */
3875 ffeste_R910_finish ()
3877 ffeste_check_finish_ ();
3879 /* Don't generate "if (iostat != 0) goto label;" if label is temp abort
3880 label, since we're gonna fall through to there anyway. */
3882 if (ffeste_io_endgfrt_ != FFECOM_gfrt)
3883 ffeste_io_call_ (ffecom_call_gfrt (ffeste_io_endgfrt_, NULL_TREE,
3885 ! ffeste_io_abort_is_temp_);
3887 /* If we've got a temp label, generate its code here. */
3889 if (ffeste_io_abort_is_temp_)
3891 DECL_INITIAL (ffeste_io_abort_) = error_mark_node;
3893 expand_label (ffeste_io_abort_);
3895 assert (ffeste_io_err_ == NULL_TREE);
3898 ffeste_end_stmt_ ();
3901 /* PRINT statement -- start. */
3904 ffeste_R911_start (ffestpPrintStmt *info, ffestvFormat format)
3910 ffeste_check_start_ ();
3912 ffeste_emit_line_note_ ();
3914 /* First determine the start, per-item, and end run-time functions to
3915 call. The per-item function is picked by choosing an ffeste function
3916 to call to handle a given item; it knows how to generate a call to the
3917 appropriate run-time function, and is called an "I/O driver". */
3921 case FFESTV_formatLABEL: /* FMT=10 */
3922 case FFESTV_formatCHAREXPR: /* FMT='(I10)' */
3923 case FFESTV_formatINTEXPR: /* FMT=I [after ASSIGN 10 TO I] */
3924 ffeste_io_driver_ = ffeste_io_dofio_;
3925 start = FFECOM_gfrtSWSFE, end = FFECOM_gfrtEWSFE;
3928 case FFESTV_formatASTERISK: /* FMT=* */
3929 ffeste_io_driver_ = ffeste_io_dolio_;
3930 start = FFECOM_gfrtSWSLE, end = FFECOM_gfrtEWSLE;
3933 case FFESTV_formatNAMELIST: /* FMT=FOO or NML=FOO [NAMELIST
3935 ffeste_io_driver_ = NULL; /* No start or driver function. */
3936 start = FFECOM_gfrtSWSNE, end = FFECOM_gfrt;
3940 assert ("Weird stuff" == NULL);
3941 start = FFECOM_gfrt, end = FFECOM_gfrt;
3944 ffeste_io_endgfrt_ = end;
3946 ffeste_start_stmt_ ();
3948 ffeste_io_end_ = NULL_TREE;
3949 ffeste_io_err_ = NULL_TREE;
3950 ffeste_io_abort_ = NULL_TREE;
3951 ffeste_io_abort_is_temp_ = FALSE;
3952 ffeste_io_iostat_is_temp_ = FALSE;
3953 ffeste_io_iostat_ = NULL_TREE;
3955 /* Now prescan, then convert, all the arguments. */
3957 cilist = ffeste_io_cilist_ (FALSE, FFESTV_unitNONE, NULL, 6, FALSE, format,
3958 &info->print_spec[FFESTP_printixFORMAT],
3961 /* If there is no end function, then there are no item functions (i.e.
3962 it's a NAMELIST), and vice versa by the way. In this situation, don't
3963 generate the "if (iostat != 0) goto label;" if the label is temp abort
3964 label, since we're gonna fall through to there anyway. */
3966 ffeste_io_call_ (ffecom_call_gfrt (start, cilist, NULL_TREE),
3967 (! ffeste_io_abort_is_temp_) || (end != FFECOM_gfrt));
3970 /* PRINT statement -- I/O item. */
3973 ffeste_R911_item (ffebld expr, ffelexToken expr_token)
3975 ffeste_check_item_ ();
3980 if (ffebld_op (expr) == FFEBLD_opANY)
3983 if (ffebld_op (expr) == FFEBLD_opIMPDO)
3984 ffeste_io_impdo_ (expr, expr_token);
3987 ffeste_start_stmt_ ();
3989 ffecom_prepare_arg_ptr_to_expr (expr);
3991 ffecom_prepare_end ();
3993 ffeste_io_call_ ((*ffeste_io_driver_) (expr), TRUE);
3995 ffeste_end_stmt_ ();
3999 /* PRINT statement -- end. */
4002 ffeste_R911_finish ()
4004 ffeste_check_finish_ ();
4006 if (ffeste_io_endgfrt_ != FFECOM_gfrt)
4007 ffeste_io_call_ (ffecom_call_gfrt (ffeste_io_endgfrt_, NULL_TREE,
4011 ffeste_end_stmt_ ();
4014 /* BACKSPACE statement. */
4017 ffeste_R919 (ffestpBeruStmt *info)
4019 ffeste_check_simple_ ();
4021 ffeste_subr_beru_ (info, FFECOM_gfrtFBACK);
4024 /* ENDFILE statement. */
4027 ffeste_R920 (ffestpBeruStmt *info)
4029 ffeste_check_simple_ ();
4031 ffeste_subr_beru_ (info, FFECOM_gfrtFEND);
4034 /* REWIND statement. */
4037 ffeste_R921 (ffestpBeruStmt *info)
4039 ffeste_check_simple_ ();
4041 ffeste_subr_beru_ (info, FFECOM_gfrtFREW);
4044 /* INQUIRE statement (non-IOLENGTH version). */
4047 ffeste_R923A (ffestpInquireStmt *info, bool by_file UNUSED)
4053 ffeste_check_simple_ ();
4055 ffeste_emit_line_note_ ();
4057 #define specified(something) (info->inquire_spec[something].kw_or_val_present)
4059 iostat = specified (FFESTP_inquireixIOSTAT);
4060 errl = specified (FFESTP_inquireixERR);
4064 ffeste_start_stmt_ ();
4070 = ffecom_lookup_label
4071 (info->inquire_spec[FFESTP_inquireixERR].u.label);
4072 ffeste_io_abort_is_temp_ = FALSE;
4076 ffeste_io_err_ = NULL_TREE;
4078 if ((ffeste_io_abort_is_temp_ = iostat))
4079 ffeste_io_abort_ = ffecom_temp_label ();
4081 ffeste_io_abort_ = NULL_TREE;
4086 /* Have IOSTAT= specification. */
4088 ffeste_io_iostat_is_temp_ = FALSE;
4089 ffeste_io_iostat_ = ffecom_expr
4090 (info->inquire_spec[FFESTP_inquireixIOSTAT].u.expr);
4092 else if (ffeste_io_abort_ != NULL_TREE)
4094 /* Have no IOSTAT= but have ERR=. */
4096 ffeste_io_iostat_is_temp_ = TRUE;
4098 = ffecom_make_tempvar ("inquire", ffecom_integer_type_node,
4099 FFETARGET_charactersizeNONE, -1);
4103 /* No IOSTAT= or ERR= specification. */
4105 ffeste_io_iostat_is_temp_ = FALSE;
4106 ffeste_io_iostat_ = NULL_TREE;
4109 /* Now prescan, then convert, all the arguments. */
4112 = ffeste_io_inlist_ (errl || iostat,
4113 &info->inquire_spec[FFESTP_inquireixUNIT],
4114 &info->inquire_spec[FFESTP_inquireixFILE],
4115 &info->inquire_spec[FFESTP_inquireixEXIST],
4116 &info->inquire_spec[FFESTP_inquireixOPENED],
4117 &info->inquire_spec[FFESTP_inquireixNUMBER],
4118 &info->inquire_spec[FFESTP_inquireixNAMED],
4119 &info->inquire_spec[FFESTP_inquireixNAME],
4120 &info->inquire_spec[FFESTP_inquireixACCESS],
4121 &info->inquire_spec[FFESTP_inquireixSEQUENTIAL],
4122 &info->inquire_spec[FFESTP_inquireixDIRECT],
4123 &info->inquire_spec[FFESTP_inquireixFORM],
4124 &info->inquire_spec[FFESTP_inquireixFORMATTED],
4125 &info->inquire_spec[FFESTP_inquireixUNFORMATTED],
4126 &info->inquire_spec[FFESTP_inquireixRECL],
4127 &info->inquire_spec[FFESTP_inquireixNEXTREC],
4128 &info->inquire_spec[FFESTP_inquireixBLANK]);
4130 /* Don't generate "if (iostat != 0) goto label;" if label is temp abort
4131 label, since we're gonna fall through to there anyway. */
4133 ffeste_io_call_ (ffecom_call_gfrt (FFECOM_gfrtFINQU, args, NULL_TREE),
4134 ! ffeste_io_abort_is_temp_);
4136 /* If we've got a temp label, generate its code here. */
4138 if (ffeste_io_abort_is_temp_)
4140 DECL_INITIAL (ffeste_io_abort_) = error_mark_node;
4142 expand_label (ffeste_io_abort_);
4144 assert (ffeste_io_err_ == NULL_TREE);
4147 ffeste_end_stmt_ ();
4150 /* INQUIRE(IOLENGTH=expr) statement -- start. */
4153 ffeste_R923B_start (ffestpInquireStmt *info UNUSED)
4155 ffeste_check_start_ ();
4157 assert ("INQUIRE(IOLENGTH=<var>) not implemented yet! ~~~" == NULL);
4159 ffeste_emit_line_note_ ();
4162 /* INQUIRE(IOLENGTH=expr) statement -- I/O item. */
4165 ffeste_R923B_item (ffebld expr UNUSED)
4167 ffeste_check_item_ ();
4170 /* INQUIRE(IOLENGTH=expr) statement -- end. */
4173 ffeste_R923B_finish ()
4175 ffeste_check_finish_ ();
4178 /* ffeste_R1001 -- FORMAT statement
4180 ffeste_R1001(format_list); */
4183 ffeste_R1001 (ffests s)
4190 ffeste_check_simple_ ();
4192 assert (ffeste_label_formatdef_ != NULL);
4194 ffeste_emit_line_note_ ();
4196 t = build_string (ffests_length (s), ffests_text (s));
4199 = build_type_variant (build_array_type
4201 build_range_type (integer_type_node,
4203 build_int_2 (ffests_length (s),
4206 TREE_CONSTANT (t) = 1;
4207 TREE_STATIC (t) = 1;
4209 var = ffecom_lookup_label (ffeste_label_formatdef_);
4210 if ((var != NULL_TREE)
4211 && (TREE_CODE (var) == VAR_DECL))
4213 DECL_INITIAL (var) = t;
4214 maxindex = build_int_2 (ffests_length (s) - 1, 0);
4215 ttype = TREE_TYPE (var);
4216 TYPE_DOMAIN (ttype) = build_range_type (integer_type_node,
4219 if (!TREE_TYPE (maxindex))
4220 TREE_TYPE (maxindex) = TYPE_DOMAIN (ttype);
4221 layout_type (ttype);
4222 rest_of_decl_compilation (var, NULL, 1, 0);
4224 expand_decl_init (var);
4227 ffeste_label_formatdef_ = NULL;
4237 /* END BLOCK DATA. */
4244 /* CALL statement. */
4247 ffeste_R1212 (ffebld expr)
4251 ffebld labels = NULL; /* First in list of LABTERs. */
4252 ffebld prevlabels = NULL;
4253 ffebld prevargs = NULL;
4255 ffeste_check_simple_ ();
4257 args = ffebld_right (expr);
4259 ffeste_emit_line_note_ ();
4261 /* Here we split the list at ffebld_right(expr) into two lists: one at
4262 ffebld_right(expr) consisting of all items that are not LABTERs, the
4263 other at labels consisting of all items that are LABTERs. Then, if
4264 the latter list is NULL, we have an ordinary call, else we have a call
4265 with alternate returns. */
4267 for (args = ffebld_right (expr); args != NULL; args = ffebld_trail (args))
4269 if (((arg = ffebld_head (args)) == NULL)
4270 || (ffebld_op (arg) != FFEBLD_opLABTER))
4272 if (prevargs == NULL)
4275 ffebld_set_right (expr, args);
4279 ffebld_set_trail (prevargs, args);
4285 if (prevlabels == NULL)
4287 prevlabels = labels = args;
4291 ffebld_set_trail (prevlabels, args);
4296 if (prevlabels == NULL)
4299 ffebld_set_trail (prevlabels, NULL);
4300 if (prevargs == NULL)
4301 ffebld_set_right (expr, NULL);
4303 ffebld_set_trail (prevargs, NULL);
4305 ffeste_start_stmt_ ();
4307 /* No temporaries are actually needed at this level, but we go
4308 through the motions anyway, just to be sure in case they do
4309 get made. Temporaries needed for arguments should be in the
4310 scopes of inner blocks, and if clean-up actions are supported,
4311 such as CALL-ing an intrinsic that writes to an argument of one
4312 type when a variable of a different type is provided (requiring
4313 assignment to the variable from a temporary after the library
4314 routine returns), the clean-up must be done by the expression
4315 evaluator, generally, to handle alternate returns (which we hope
4316 won't ever be supported by intrinsics, but might be a similar
4317 issue, such as CALL-ing an F90-style subroutine with an INTERFACE
4318 block). That implies the expression evaluator will have to
4319 recognize the need for its own temporary anyway, meaning it'll
4320 construct a block within the one constructed here. */
4322 ffecom_prepare_expr (expr);
4324 ffecom_prepare_end ();
4327 expand_expr_stmt (ffecom_expr (expr));
4338 texpr = ffecom_expr (expr);
4339 expand_start_case (0, texpr, TREE_TYPE (texpr), "CALL statement");
4341 for (caseno = 1, label = labels;
4343 ++caseno, label = ffebld_trail (label))
4345 value = build_int_2 (caseno, 0);
4346 tlabel = build_decl (LABEL_DECL, NULL_TREE, NULL_TREE);
4348 pushok = pushcase (value, convert, tlabel, &duplicate);
4349 assert (pushok == 0);
4352 = ffecom_lookup_label (ffebld_labter (ffebld_head (label)));
4353 if ((tlabel == NULL_TREE)
4354 || (TREE_CODE (tlabel) == ERROR_MARK))
4356 TREE_USED (tlabel) = 1;
4357 expand_goto (tlabel);
4360 expand_end_case (texpr);
4363 ffeste_end_stmt_ ();
4373 /* END SUBROUTINE. */
4380 /* ENTRY statement. */
4383 ffeste_R1226 (ffesymbol entry)
4387 ffeste_check_simple_ ();
4389 label = ffesymbol_hook (entry).length_tree;
4391 ffeste_emit_line_note_ ();
4393 if (label == error_mark_node)
4396 DECL_INITIAL (label) = error_mark_node;
4398 expand_label (label);
4401 /* RETURN statement. */
4404 ffeste_R1227 (ffestw block UNUSED, ffebld expr)
4408 ffeste_check_simple_ ();
4410 ffeste_emit_line_note_ ();
4412 ffeste_start_stmt_ ();
4414 ffecom_prepare_return_expr (expr);
4416 ffecom_prepare_end ();
4418 rtn = ffecom_return_expr (expr);
4420 if ((rtn == NULL_TREE)
4421 || (rtn == error_mark_node))
4422 expand_null_return ();
4425 tree result = DECL_RESULT (current_function_decl);
4427 if ((result != error_mark_node)
4428 && (TREE_TYPE (result) != error_mark_node))
4429 expand_return (ffecom_modify (NULL_TREE,
4431 convert (TREE_TYPE (result),
4434 expand_null_return ();
4437 ffeste_end_stmt_ ();
4440 /* REWRITE statement -- start. */
4444 ffeste_V018_start (ffestpRewriteStmt *info, ffestvFormat format)
4446 ffeste_check_start_ ();
4449 /* REWRITE statement -- I/O item. */
4452 ffeste_V018_item (ffebld expr)
4454 ffeste_check_item_ ();
4457 /* REWRITE statement -- end. */
4460 ffeste_V018_finish ()
4462 ffeste_check_finish_ ();
4465 /* ACCEPT statement -- start. */
4468 ffeste_V019_start (ffestpAcceptStmt *info, ffestvFormat format)
4470 ffeste_check_start_ ();
4473 /* ACCEPT statement -- I/O item. */
4476 ffeste_V019_item (ffebld expr)
4478 ffeste_check_item_ ();
4481 /* ACCEPT statement -- end. */
4484 ffeste_V019_finish ()
4486 ffeste_check_finish_ ();
4490 /* TYPE statement -- start. */
4493 ffeste_V020_start (ffestpTypeStmt *info UNUSED,
4494 ffestvFormat format UNUSED)
4496 ffeste_check_start_ ();
4499 /* TYPE statement -- I/O item. */
4502 ffeste_V020_item (ffebld expr UNUSED)
4504 ffeste_check_item_ ();
4507 /* TYPE statement -- end. */
4510 ffeste_V020_finish ()
4512 ffeste_check_finish_ ();
4515 /* DELETE statement. */
4519 ffeste_V021 (ffestpDeleteStmt *info)
4521 ffeste_check_simple_ ();
4524 /* UNLOCK statement. */
4527 ffeste_V022 (ffestpBeruStmt *info)
4529 ffeste_check_simple_ ();
4532 /* ENCODE statement -- start. */
4535 ffeste_V023_start (ffestpVxtcodeStmt *info)
4537 ffeste_check_start_ ();
4540 /* ENCODE statement -- I/O item. */
4543 ffeste_V023_item (ffebld expr)
4545 ffeste_check_item_ ();
4548 /* ENCODE statement -- end. */
4551 ffeste_V023_finish ()
4553 ffeste_check_finish_ ();
4556 /* DECODE statement -- start. */
4559 ffeste_V024_start (ffestpVxtcodeStmt *info)
4561 ffeste_check_start_ ();
4564 /* DECODE statement -- I/O item. */
4567 ffeste_V024_item (ffebld expr)
4569 ffeste_check_item_ ();
4572 /* DECODE statement -- end. */
4575 ffeste_V024_finish ()
4577 ffeste_check_finish_ ();
4580 /* DEFINEFILE statement -- start. */
4583 ffeste_V025_start ()
4585 ffeste_check_start_ ();
4588 /* DEFINE FILE statement -- item. */
4591 ffeste_V025_item (ffebld u, ffebld m, ffebld n, ffebld asv)
4593 ffeste_check_item_ ();
4596 /* DEFINE FILE statement -- end. */
4599 ffeste_V025_finish ()
4601 ffeste_check_finish_ ();
4604 /* FIND statement. */
4607 ffeste_V026 (ffestpFindStmt *info)
4609 ffeste_check_simple_ ();
4614 #ifdef ENABLE_CHECKING
4616 ffeste_terminate_2 (void)
4618 assert (! ffeste_top_block_);