1 /* ste.c -- Implementation File (module.c template V1.0)
2 Copyright (C) 1995, 1996, 2000 Free Software Foundation, Inc.
3 Contributed by James Craig Burley.
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_if_false (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 ffebad_start_msg ("SELECT CASE on CHARACTER type (at %0) not supported -- sorry",
2636 FFEBAD_severityFATAL
);
2637 ffebad_here (0, ffestw_line (block
), ffestw_col (block
));
2639 ffestw_set_select_texpr (block
, error_mark_node
);
2646 result
= ffecom_make_tempvar ("select", ffecom_type_expr (expr
),
2647 ffeinfo_size (ffebld_info (expr
)),
2650 ffeste_start_stmt_ ();
2652 ffecom_prepare_expr (expr
);
2654 ffecom_prepare_end ();
2656 texpr
= ffecom_expr (expr
);
2658 assert (TYPE_MAIN_VARIANT (TREE_TYPE (texpr
))
2659 == TYPE_MAIN_VARIANT (TREE_TYPE (result
)));
2661 texpr
= ffecom_modify (void_type_node
,
2664 expand_expr_stmt (texpr
);
2666 ffeste_end_stmt_ ();
2668 expand_start_case (1, result
, TREE_TYPE (result
),
2669 "SELECT CASE statement");
2670 ffestw_set_select_texpr (block
, texpr
);
2671 ffestw_set_select_break (block
, FALSE
);
2677 If casenum is 0, it's CASE DEFAULT. Else it's the case ranges at
2678 the start of the first_stmt list in the select object at the top of
2679 the stack that match casenum. */
2682 ffeste_R810 (ffestw block
, unsigned long casenum
)
2684 ffestwSelect s
= ffestw_select (block
);
2692 ffeste_check_simple_ ();
2694 if (s
->first_stmt
== (ffestwCase
) &s
->first_rel
)
2699 ffeste_emit_line_note_ ();
2701 if (ffestw_select_texpr (block
) == error_mark_node
)
2704 /* ~~~Someday handle CHARACTER*1, CHARACTER*N */
2706 tlabel
= build_decl (LABEL_DECL
, NULL_TREE
, NULL_TREE
);
2708 if (ffestw_select_break (block
))
2709 expand_exit_something ();
2711 ffestw_set_select_break (block
, TRUE
);
2713 if ((c
== NULL
) || (casenum
!= c
->casenum
))
2715 if (casenum
== 0) /* Intentional CASE DEFAULT. */
2717 pushok
= pushcase (NULL_TREE
, 0, tlabel
, &duplicate
);
2718 assert (pushok
== 0);
2724 texprlow
= (c
->low
== NULL
) ? NULL_TREE
2725 : ffecom_constantunion (&ffebld_constant_union (c
->low
), s
->type
,
2727 ffecom_tree_type
[s
->type
][s
->kindtype
]);
2728 if (c
->low
!= c
->high
)
2730 texprhigh
= (c
->high
== NULL
) ? NULL_TREE
2731 : ffecom_constantunion (&ffebld_constant_union (c
->high
),
2732 s
->type
, s
->kindtype
,
2733 ffecom_tree_type
[s
->type
][s
->kindtype
]);
2734 pushok
= pushcase_range (texprlow
, texprhigh
, convert
,
2735 tlabel
, &duplicate
);
2738 pushok
= pushcase (texprlow
, convert
, tlabel
, &duplicate
);
2739 assert (pushok
== 0);
2742 c
->previous_stmt
->previous_stmt
->next_stmt
= c
;
2743 c
->previous_stmt
= c
->previous_stmt
->previous_stmt
;
2745 while ((c
!= (ffestwCase
) &s
->first_rel
) && (casenum
== c
->casenum
));
2748 /* END SELECT statement. */
2751 ffeste_R811 (ffestw block
)
2753 ffeste_emit_line_note_ ();
2755 /* ~~~Someday handle CHARACTER*1, CHARACTER*N */
2757 if (TREE_CODE (ffestw_select_texpr (block
)) != ERROR_MARK
)
2758 expand_end_case (ffestw_select_texpr (block
));
2760 ffeste_end_block_ (block
);
2763 /* Iterative DO statement. */
2766 ffeste_R819A (ffestw block
, ffelab label UNUSED
, ffebld var
,
2767 ffebld start
, ffelexToken start_token
,
2768 ffebld end
, ffelexToken end_token
,
2769 ffebld incr
, ffelexToken incr_token
)
2771 ffeste_check_simple_ ();
2773 ffeste_emit_line_note_ ();
2775 ffeste_begin_iterdo_ (block
, NULL
, NULL
, NULL
,
2780 "Iterative DO loop");
2783 /* DO WHILE statement. */
2786 ffeste_R819B (ffestw block
, ffelab label UNUSED
, ffebld expr
)
2790 ffeste_check_simple_ ();
2792 ffeste_emit_line_note_ ();
2794 ffeste_start_block_ (block
);
2798 struct nesting
*loop
;
2801 result
= ffecom_make_tempvar ("dowhile", integer_type_node
,
2802 FFETARGET_charactersizeNONE
, -1);
2803 loop
= expand_start_loop (1);
2805 ffeste_start_stmt_ ();
2807 ffecom_prepare_expr (expr
);
2809 ffecom_prepare_end ();
2811 mod
= ffecom_modify (void_type_node
,
2813 ffecom_truth_value (ffecom_expr (expr
)));
2814 expand_expr_stmt (mod
);
2816 ffeste_end_stmt_ ();
2818 ffestw_set_do_hook (block
, loop
);
2819 expand_exit_loop_if_false (0, result
);
2822 ffestw_set_do_hook (block
, expand_start_loop (1));
2824 ffestw_set_do_tvar (block
, NULL_TREE
);
2827 /* END DO statement.
2829 This is the MIL-STD 1753 END DO. It's syntactic sugar, similar to
2830 CONTINUE (except that it has to have a label that is the target of
2831 one or more iterative DO statement), not the Fortran-90 structured
2832 END DO, which is handled elsewhere, as is the actual mechanism of
2833 ending an iterative DO statement, even one that ends at a label. */
2838 ffeste_check_simple_ ();
2840 ffeste_emit_line_note_ ();
2845 /* CYCLE statement. */
2848 ffeste_R834 (ffestw block
)
2850 ffeste_check_simple_ ();
2852 ffeste_emit_line_note_ ();
2854 expand_continue_loop (ffestw_do_hook (block
));
2857 /* EXIT statement. */
2860 ffeste_R835 (ffestw block
)
2862 ffeste_check_simple_ ();
2864 ffeste_emit_line_note_ ();
2866 expand_exit_loop (ffestw_do_hook (block
));
2869 /* GOTO statement. */
2872 ffeste_R836 (ffelab label
)
2876 ffeste_check_simple_ ();
2878 ffeste_emit_line_note_ ();
2880 glabel
= ffecom_lookup_label (label
);
2881 if ((glabel
!= NULL_TREE
)
2882 && (TREE_CODE (glabel
) != ERROR_MARK
))
2884 expand_goto (glabel
);
2885 TREE_USED (glabel
) = 1;
2889 /* Computed GOTO statement. */
2892 ffeste_R837 (ffelab
*labels
, int count
, ffebld expr
)
2901 ffeste_check_simple_ ();
2903 ffeste_emit_line_note_ ();
2905 ffeste_start_stmt_ ();
2907 ffecom_prepare_expr (expr
);
2909 ffecom_prepare_end ();
2911 texpr
= ffecom_expr (expr
);
2913 expand_start_case (0, texpr
, TREE_TYPE (texpr
), "computed GOTO statement");
2915 for (i
= 0; i
< count
; ++i
)
2917 value
= build_int_2 (i
+ 1, 0);
2918 tlabel
= build_decl (LABEL_DECL
, NULL_TREE
, NULL_TREE
);
2920 pushok
= pushcase (value
, convert
, tlabel
, &duplicate
);
2921 assert (pushok
== 0);
2923 tlabel
= ffecom_lookup_label (labels
[i
]);
2924 if ((tlabel
== NULL_TREE
)
2925 || (TREE_CODE (tlabel
) == ERROR_MARK
))
2928 expand_goto (tlabel
);
2929 TREE_USED (tlabel
) = 1;
2931 expand_end_case (texpr
);
2933 ffeste_end_stmt_ ();
2936 /* ASSIGN statement. */
2939 ffeste_R838 (ffelab label
, ffebld target
)
2945 ffeste_check_simple_ ();
2947 ffeste_emit_line_note_ ();
2949 /* No need to call ffeste_start_stmt_(), as the sorts of expressions
2950 seen here should never require use of temporaries. */
2952 label_tree
= ffecom_lookup_label (label
);
2953 if ((label_tree
!= NULL_TREE
)
2954 && (TREE_CODE (label_tree
) != ERROR_MARK
))
2956 label_tree
= ffecom_1 (ADDR_EXPR
,
2957 build_pointer_type (void_type_node
),
2959 TREE_CONSTANT (label_tree
) = 1;
2961 target_tree
= ffecom_expr_assign_w (target
);
2962 if (GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (target_tree
)))
2963 < GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (label_tree
))))
2964 error ("ASSIGN to variable that is too small");
2966 label_tree
= convert (TREE_TYPE (target_tree
), label_tree
);
2968 expr_tree
= ffecom_modify (void_type_node
,
2971 expand_expr_stmt (expr_tree
);
2975 /* Assigned GOTO statement. */
2978 ffeste_R839 (ffebld target
)
2982 ffeste_check_simple_ ();
2984 ffeste_emit_line_note_ ();
2986 /* No need to call ffeste_start_stmt_(), as the sorts of expressions
2987 seen here should never require use of temporaries. */
2989 t
= ffecom_expr_assign (target
);
2990 if (GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (t
)))
2991 < GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node
))))
2992 error ("ASSIGNed GOTO target variable is too small");
2994 expand_computed_goto (convert (TREE_TYPE (null_pointer_node
), t
));
2997 /* Arithmetic IF statement. */
3000 ffeste_R840 (ffebld expr
, ffelab neg
, ffelab zero
, ffelab pos
)
3002 tree gneg
= ffecom_lookup_label (neg
);
3003 tree gzero
= ffecom_lookup_label (zero
);
3004 tree gpos
= ffecom_lookup_label (pos
);
3007 ffeste_check_simple_ ();
3009 ffeste_emit_line_note_ ();
3011 if ((gneg
== NULL_TREE
) || (gzero
== NULL_TREE
) || (gpos
== NULL_TREE
))
3013 if ((TREE_CODE (gneg
) == ERROR_MARK
)
3014 || (TREE_CODE (gzero
) == ERROR_MARK
)
3015 || (TREE_CODE (gpos
) == ERROR_MARK
))
3018 ffeste_start_stmt_ ();
3020 ffecom_prepare_expr (expr
);
3022 ffecom_prepare_end ();
3027 expand_goto (gzero
);
3030 /* IF (expr.LE.0) THEN GOTO neg/zero ELSE GOTO pos. */
3031 texpr
= ffecom_expr (expr
);
3032 texpr
= ffecom_2 (LE_EXPR
, integer_type_node
,
3034 convert (TREE_TYPE (texpr
),
3035 integer_zero_node
));
3036 expand_start_cond (ffecom_truth_value (texpr
), 0);
3037 expand_goto (gzero
);
3038 expand_start_else ();
3043 else if (neg
== pos
)
3045 /* IF (expr.NE.0) THEN GOTO neg/pos ELSE GOTO zero. */
3046 texpr
= ffecom_expr (expr
);
3047 texpr
= ffecom_2 (NE_EXPR
, integer_type_node
,
3049 convert (TREE_TYPE (texpr
),
3050 integer_zero_node
));
3051 expand_start_cond (ffecom_truth_value (texpr
), 0);
3053 expand_start_else ();
3054 expand_goto (gzero
);
3057 else if (zero
== pos
)
3059 /* IF (expr.GE.0) THEN GOTO zero/pos ELSE GOTO neg. */
3060 texpr
= ffecom_expr (expr
);
3061 texpr
= ffecom_2 (GE_EXPR
, integer_type_node
,
3063 convert (TREE_TYPE (texpr
),
3064 integer_zero_node
));
3065 expand_start_cond (ffecom_truth_value (texpr
), 0);
3066 expand_goto (gzero
);
3067 expand_start_else ();
3073 /* Use a SAVE_EXPR in combo with:
3074 IF (expr.LT.0) THEN GOTO neg
3075 ELSEIF (expr.GT.0) THEN GOTO pos
3077 tree expr_saved
= ffecom_save_tree (ffecom_expr (expr
));
3079 texpr
= ffecom_2 (LT_EXPR
, integer_type_node
,
3081 convert (TREE_TYPE (expr_saved
),
3082 integer_zero_node
));
3083 expand_start_cond (ffecom_truth_value (texpr
), 0);
3085 texpr
= ffecom_2 (GT_EXPR
, integer_type_node
,
3087 convert (TREE_TYPE (expr_saved
),
3088 integer_zero_node
));
3089 expand_start_elseif (ffecom_truth_value (texpr
));
3091 expand_start_else ();
3092 expand_goto (gzero
);
3096 ffeste_end_stmt_ ();
3099 /* CONTINUE statement. */
3104 ffeste_check_simple_ ();
3106 ffeste_emit_line_note_ ();
3111 /* STOP statement. */
3114 ffeste_R842 (ffebld expr
)
3119 ffeste_check_simple_ ();
3121 ffeste_emit_line_note_ ();
3124 || (ffeinfo_basictype (ffebld_info (expr
))
3125 == FFEINFO_basictypeANY
))
3127 msg
= ffelex_token_new_character ("",
3128 ffelex_token_where_line (ffesta_tokens
[0]),
3129 ffelex_token_where_column (ffesta_tokens
[0]));
3130 expr
= ffebld_new_conter (ffebld_constant_new_characterdefault
3132 ffelex_token_kill (msg
);
3133 ffebld_set_info (expr
, ffeinfo_new (FFEINFO_basictypeCHARACTER
,
3134 FFEINFO_kindtypeCHARACTERDEFAULT
,
3135 0, FFEINFO_kindENTITY
,
3136 FFEINFO_whereCONSTANT
, 0));
3138 else if (ffeinfo_basictype (ffebld_info (expr
))
3139 == FFEINFO_basictypeINTEGER
)
3143 assert (ffebld_op (expr
) == FFEBLD_opCONTER
);
3144 assert (ffeinfo_kindtype (ffebld_info (expr
))
3145 == FFEINFO_kindtypeINTEGERDEFAULT
);
3146 sprintf (num
, "%" ffetargetIntegerDefault_f
"d",
3147 ffebld_constant_integer1 (ffebld_conter (expr
)));
3148 msg
= ffelex_token_new_character (num
,
3149 ffelex_token_where_line (ffesta_tokens
[0]),
3150 ffelex_token_where_column (ffesta_tokens
[0]));
3151 expr
= ffebld_new_conter (ffebld_constant_new_characterdefault (msg
));
3152 ffelex_token_kill (msg
);
3153 ffebld_set_info (expr
, ffeinfo_new (FFEINFO_basictypeCHARACTER
,
3154 FFEINFO_kindtypeCHARACTERDEFAULT
,
3155 0, FFEINFO_kindENTITY
,
3156 FFEINFO_whereCONSTANT
, 0));
3160 assert (ffeinfo_basictype (ffebld_info (expr
))
3161 == FFEINFO_basictypeCHARACTER
);
3162 assert (ffebld_op (expr
) == FFEBLD_opCONTER
);
3163 assert (ffeinfo_kindtype (ffebld_info (expr
))
3164 == FFEINFO_kindtypeCHARACTERDEFAULT
);
3167 /* No need to call ffeste_start_stmt_(), as the sorts of expressions
3168 seen here should never require use of temporaries. */
3170 callit
= ffecom_call_gfrt (FFECOM_gfrtSTOP
,
3171 ffecom_list_ptr_to_expr (ffebld_new_item (expr
, NULL
)),
3173 TREE_SIDE_EFFECTS (callit
) = 1;
3175 expand_expr_stmt (callit
);
3178 /* PAUSE statement. */
3181 ffeste_R843 (ffebld expr
)
3186 ffeste_check_simple_ ();
3188 ffeste_emit_line_note_ ();
3191 || (ffeinfo_basictype (ffebld_info (expr
))
3192 == FFEINFO_basictypeANY
))
3194 msg
= ffelex_token_new_character ("",
3195 ffelex_token_where_line (ffesta_tokens
[0]),
3196 ffelex_token_where_column (ffesta_tokens
[0]));
3197 expr
= ffebld_new_conter (ffebld_constant_new_characterdefault (msg
));
3198 ffelex_token_kill (msg
);
3199 ffebld_set_info (expr
, ffeinfo_new (FFEINFO_basictypeCHARACTER
,
3200 FFEINFO_kindtypeCHARACTERDEFAULT
,
3201 0, FFEINFO_kindENTITY
,
3202 FFEINFO_whereCONSTANT
, 0));
3204 else if (ffeinfo_basictype (ffebld_info (expr
)) == FFEINFO_basictypeINTEGER
)
3208 assert (ffebld_op (expr
) == FFEBLD_opCONTER
);
3209 assert (ffeinfo_kindtype (ffebld_info (expr
))
3210 == FFEINFO_kindtypeINTEGERDEFAULT
);
3211 sprintf (num
, "%" ffetargetIntegerDefault_f
"d",
3212 ffebld_constant_integer1 (ffebld_conter (expr
)));
3213 msg
= ffelex_token_new_character (num
, ffelex_token_where_line (ffesta_tokens
[0]),
3214 ffelex_token_where_column (ffesta_tokens
[0]));
3215 expr
= ffebld_new_conter (ffebld_constant_new_characterdefault (msg
));
3216 ffelex_token_kill (msg
);
3217 ffebld_set_info (expr
, ffeinfo_new (FFEINFO_basictypeCHARACTER
,
3218 FFEINFO_kindtypeCHARACTERDEFAULT
,
3219 0, FFEINFO_kindENTITY
,
3220 FFEINFO_whereCONSTANT
, 0));
3224 assert (ffeinfo_basictype (ffebld_info (expr
))
3225 == FFEINFO_basictypeCHARACTER
);
3226 assert (ffebld_op (expr
) == FFEBLD_opCONTER
);
3227 assert (ffeinfo_kindtype (ffebld_info (expr
))
3228 == FFEINFO_kindtypeCHARACTERDEFAULT
);
3231 /* No need to call ffeste_start_stmt_(), as the sorts of expressions
3232 seen here should never require use of temporaries. */
3234 callit
= ffecom_call_gfrt (FFECOM_gfrtPAUSE
,
3235 ffecom_list_ptr_to_expr (ffebld_new_item (expr
, NULL
)),
3237 TREE_SIDE_EFFECTS (callit
) = 1;
3239 expand_expr_stmt (callit
);
3242 /* OPEN statement. */
3245 ffeste_R904 (ffestpOpenStmt
*info
)
3251 ffeste_check_simple_ ();
3253 ffeste_emit_line_note_ ();
3255 #define specified(something) (info->open_spec[something].kw_or_val_present)
3257 iostat
= specified (FFESTP_openixIOSTAT
);
3258 errl
= specified (FFESTP_openixERR
);
3262 ffeste_start_stmt_ ();
3268 = ffecom_lookup_label
3269 (info
->open_spec
[FFESTP_openixERR
].u
.label
);
3270 ffeste_io_abort_is_temp_
= FALSE
;
3274 ffeste_io_err_
= NULL_TREE
;
3276 if ((ffeste_io_abort_is_temp_
= iostat
))
3277 ffeste_io_abort_
= ffecom_temp_label ();
3279 ffeste_io_abort_
= NULL_TREE
;
3284 /* Have IOSTAT= specification. */
3286 ffeste_io_iostat_is_temp_
= FALSE
;
3287 ffeste_io_iostat_
= ffecom_expr
3288 (info
->open_spec
[FFESTP_openixIOSTAT
].u
.expr
);
3290 else if (ffeste_io_abort_
!= NULL_TREE
)
3292 /* Have no IOSTAT= but have ERR=. */
3294 ffeste_io_iostat_is_temp_
= TRUE
;
3296 = ffecom_make_tempvar ("open", ffecom_integer_type_node
,
3297 FFETARGET_charactersizeNONE
, -1);
3301 /* No IOSTAT= or ERR= specification. */
3303 ffeste_io_iostat_is_temp_
= FALSE
;
3304 ffeste_io_iostat_
= NULL_TREE
;
3307 /* Now prescan, then convert, all the arguments. */
3309 args
= ffeste_io_olist_ (errl
|| iostat
,
3310 info
->open_spec
[FFESTP_openixUNIT
].u
.expr
,
3311 &info
->open_spec
[FFESTP_openixFILE
],
3312 &info
->open_spec
[FFESTP_openixSTATUS
],
3313 &info
->open_spec
[FFESTP_openixACCESS
],
3314 &info
->open_spec
[FFESTP_openixFORM
],
3315 &info
->open_spec
[FFESTP_openixRECL
],
3316 &info
->open_spec
[FFESTP_openixBLANK
]);
3318 /* Don't generate "if (iostat != 0) goto label;" if label is temp abort
3319 label, since we're gonna fall through to there anyway. */
3321 ffeste_io_call_ (ffecom_call_gfrt (FFECOM_gfrtFOPEN
, args
, NULL_TREE
),
3322 ! ffeste_io_abort_is_temp_
);
3324 /* If we've got a temp label, generate its code here. */
3326 if (ffeste_io_abort_is_temp_
)
3328 DECL_INITIAL (ffeste_io_abort_
) = error_mark_node
;
3330 expand_label (ffeste_io_abort_
);
3332 assert (ffeste_io_err_
== NULL_TREE
);
3335 ffeste_end_stmt_ ();
3338 /* CLOSE statement. */
3341 ffeste_R907 (ffestpCloseStmt
*info
)
3347 ffeste_check_simple_ ();
3349 ffeste_emit_line_note_ ();
3351 #define specified(something) (info->close_spec[something].kw_or_val_present)
3353 iostat
= specified (FFESTP_closeixIOSTAT
);
3354 errl
= specified (FFESTP_closeixERR
);
3358 ffeste_start_stmt_ ();
3364 = ffecom_lookup_label
3365 (info
->close_spec
[FFESTP_closeixERR
].u
.label
);
3366 ffeste_io_abort_is_temp_
= FALSE
;
3370 ffeste_io_err_
= NULL_TREE
;
3372 if ((ffeste_io_abort_is_temp_
= iostat
))
3373 ffeste_io_abort_
= ffecom_temp_label ();
3375 ffeste_io_abort_
= NULL_TREE
;
3380 /* Have IOSTAT= specification. */
3382 ffeste_io_iostat_is_temp_
= FALSE
;
3383 ffeste_io_iostat_
= ffecom_expr
3384 (info
->close_spec
[FFESTP_closeixIOSTAT
].u
.expr
);
3386 else if (ffeste_io_abort_
!= NULL_TREE
)
3388 /* Have no IOSTAT= but have ERR=. */
3390 ffeste_io_iostat_is_temp_
= TRUE
;
3392 = ffecom_make_tempvar ("close", ffecom_integer_type_node
,
3393 FFETARGET_charactersizeNONE
, -1);
3397 /* No IOSTAT= or ERR= specification. */
3399 ffeste_io_iostat_is_temp_
= FALSE
;
3400 ffeste_io_iostat_
= NULL_TREE
;
3403 /* Now prescan, then convert, all the arguments. */
3405 args
= ffeste_io_cllist_ (errl
|| iostat
,
3406 info
->close_spec
[FFESTP_closeixUNIT
].u
.expr
,
3407 &info
->close_spec
[FFESTP_closeixSTATUS
]);
3409 /* Don't generate "if (iostat != 0) goto label;" if label is temp abort
3410 label, since we're gonna fall through to there anyway. */
3412 ffeste_io_call_ (ffecom_call_gfrt (FFECOM_gfrtFCLOS
, args
, NULL_TREE
),
3413 ! ffeste_io_abort_is_temp_
);
3415 /* If we've got a temp label, generate its code here. */
3417 if (ffeste_io_abort_is_temp_
)
3419 DECL_INITIAL (ffeste_io_abort_
) = error_mark_node
;
3421 expand_label (ffeste_io_abort_
);
3423 assert (ffeste_io_err_
== NULL_TREE
);
3426 ffeste_end_stmt_ ();
3429 /* READ(...) statement -- start. */
3432 ffeste_R909_start (ffestpReadStmt
*info
, bool only_format UNUSED
,
3433 ffestvUnit unit
, ffestvFormat format
, bool rec
,
3443 ffeste_check_start_ ();
3445 ffeste_emit_line_note_ ();
3447 /* First determine the start, per-item, and end run-time functions to
3448 call. The per-item function is picked by choosing an ffeste function
3449 to call to handle a given item; it knows how to generate a call to the
3450 appropriate run-time function, and is called an "I/O driver". */
3454 case FFESTV_formatNONE
: /* no FMT= */
3455 ffeste_io_driver_
= ffeste_io_douio_
;
3457 start
= FFECOM_gfrtSRDUE
, end
= FFECOM_gfrtERDUE
;
3459 start
= FFECOM_gfrtSRSUE
, end
= FFECOM_gfrtERSUE
;
3462 case FFESTV_formatLABEL
: /* FMT=10 */
3463 case FFESTV_formatCHAREXPR
: /* FMT='(I10)' */
3464 case FFESTV_formatINTEXPR
: /* FMT=I [after ASSIGN 10 TO I] */
3465 ffeste_io_driver_
= ffeste_io_dofio_
;
3467 start
= FFECOM_gfrtSRDFE
, end
= FFECOM_gfrtERDFE
;
3468 else if (unit
== FFESTV_unitCHAREXPR
)
3469 start
= FFECOM_gfrtSRSFI
, end
= FFECOM_gfrtERSFI
;
3471 start
= FFECOM_gfrtSRSFE
, end
= FFECOM_gfrtERSFE
;
3474 case FFESTV_formatASTERISK
: /* FMT=* */
3475 ffeste_io_driver_
= ffeste_io_dolio_
;
3476 if (unit
== FFESTV_unitCHAREXPR
)
3477 start
= FFECOM_gfrtSRSLI
, end
= FFECOM_gfrtERSLI
;
3479 start
= FFECOM_gfrtSRSLE
, end
= FFECOM_gfrtERSLE
;
3482 case FFESTV_formatNAMELIST
: /* FMT=FOO or NML=FOO [NAMELIST
3484 ffeste_io_driver_
= NULL
; /* No start or driver function. */
3485 start
= FFECOM_gfrtSRSNE
, end
= FFECOM_gfrt
;
3489 assert ("Weird stuff" == NULL
);
3490 start
= FFECOM_gfrt
, end
= FFECOM_gfrt
;
3493 ffeste_io_endgfrt_
= end
;
3495 #define specified(something) (info->read_spec[something].kw_or_val_present)
3497 iostat
= specified (FFESTP_readixIOSTAT
);
3498 errl
= specified (FFESTP_readixERR
);
3499 endl
= specified (FFESTP_readixEND
);
3503 ffeste_start_stmt_ ();
3507 /* Have ERR= specification. */
3510 = ffecom_lookup_label (info
->read_spec
[FFESTP_readixERR
].u
.label
);
3514 /* Have both ERR= and END=. Need a temp label to handle both. */
3516 = ffecom_lookup_label (info
->read_spec
[FFESTP_readixEND
].u
.label
);
3517 ffeste_io_abort_is_temp_
= TRUE
;
3518 ffeste_io_abort_
= ffecom_temp_label ();
3522 /* Have ERR= but no END=. */
3523 ffeste_io_end_
= NULL_TREE
;
3524 if ((ffeste_io_abort_is_temp_
= iostat
))
3525 ffeste_io_abort_
= ffecom_temp_label ();
3527 ffeste_io_abort_
= ffeste_io_err_
;
3532 /* No ERR= specification. */
3534 ffeste_io_err_
= NULL_TREE
;
3537 /* Have END= but no ERR=. */
3539 = ffecom_lookup_label (info
->read_spec
[FFESTP_readixEND
].u
.label
);
3540 if ((ffeste_io_abort_is_temp_
= iostat
))
3541 ffeste_io_abort_
= ffecom_temp_label ();
3543 ffeste_io_abort_
= ffeste_io_end_
;
3547 /* Have no ERR= or END=. */
3549 ffeste_io_end_
= NULL_TREE
;
3550 if ((ffeste_io_abort_is_temp_
= iostat
))
3551 ffeste_io_abort_
= ffecom_temp_label ();
3553 ffeste_io_abort_
= NULL_TREE
;
3559 /* Have IOSTAT= specification. */
3561 ffeste_io_iostat_is_temp_
= FALSE
;
3563 = ffecom_expr (info
->read_spec
[FFESTP_readixIOSTAT
].u
.expr
);
3565 else if (ffeste_io_abort_
!= NULL_TREE
)
3567 /* Have no IOSTAT= but have ERR= and/or END=. */
3569 ffeste_io_iostat_is_temp_
= TRUE
;
3571 = ffecom_make_tempvar ("read", ffecom_integer_type_node
,
3572 FFETARGET_charactersizeNONE
, -1);
3576 /* No IOSTAT=, ERR=, or END= specification. */
3578 ffeste_io_iostat_is_temp_
= FALSE
;
3579 ffeste_io_iostat_
= NULL_TREE
;
3582 /* Now prescan, then convert, all the arguments. */
3584 if (unit
== FFESTV_unitCHAREXPR
)
3585 cilist
= ffeste_io_icilist_ (errl
|| iostat
,
3586 info
->read_spec
[FFESTP_readixUNIT
].u
.expr
,
3587 endl
|| iostat
, format
,
3588 &info
->read_spec
[FFESTP_readixFORMAT
]);
3590 cilist
= ffeste_io_cilist_ (errl
|| iostat
, unit
,
3591 info
->read_spec
[FFESTP_readixUNIT
].u
.expr
,
3592 5, endl
|| iostat
, format
,
3593 &info
->read_spec
[FFESTP_readixFORMAT
],
3595 info
->read_spec
[FFESTP_readixREC
].u
.expr
);
3597 /* If there is no end function, then there are no item functions (i.e.
3598 it's a NAMELIST), and vice versa by the way. In this situation, don't
3599 generate the "if (iostat != 0) goto label;" if the label is temp abort
3600 label, since we're gonna fall through to there anyway. */
3602 ffeste_io_call_ (ffecom_call_gfrt (start
, cilist
, NULL_TREE
),
3603 (! ffeste_io_abort_is_temp_
) || (end
!= FFECOM_gfrt
));
3606 /* READ statement -- I/O item. */
3609 ffeste_R909_item (ffebld expr
, ffelexToken expr_token
)
3611 ffeste_check_item_ ();
3616 /* Strip parens off items such as in "READ *,(A)". This is really a bug
3617 in the user's code, but I've been told lots of code does this. */
3618 while (ffebld_op (expr
) == FFEBLD_opPAREN
)
3619 expr
= ffebld_left (expr
);
3621 if (ffebld_op (expr
) == FFEBLD_opANY
)
3624 if (ffebld_op (expr
) == FFEBLD_opIMPDO
)
3625 ffeste_io_impdo_ (expr
, expr_token
);
3628 ffeste_start_stmt_ ();
3630 ffecom_prepare_arg_ptr_to_expr (expr
);
3632 ffecom_prepare_end ();
3634 ffeste_io_call_ ((*ffeste_io_driver_
) (expr
), TRUE
);
3636 ffeste_end_stmt_ ();
3640 /* READ statement -- end. */
3643 ffeste_R909_finish ()
3645 ffeste_check_finish_ ();
3647 /* Don't generate "if (iostat != 0) goto label;" if label is temp abort
3648 label, since we're gonna fall through to there anyway. */
3650 if (ffeste_io_endgfrt_
!= FFECOM_gfrt
)
3651 ffeste_io_call_ (ffecom_call_gfrt (ffeste_io_endgfrt_
, NULL_TREE
,
3653 ! ffeste_io_abort_is_temp_
);
3655 /* If we've got a temp label, generate its code here and have it fan out
3656 to the END= or ERR= label as appropriate. */
3658 if (ffeste_io_abort_is_temp_
)
3660 DECL_INITIAL (ffeste_io_abort_
) = error_mark_node
;
3662 expand_label (ffeste_io_abort_
);
3664 /* "if (iostat<0) goto end_label;". */
3666 if ((ffeste_io_end_
!= NULL_TREE
)
3667 && (TREE_CODE (ffeste_io_end_
) != ERROR_MARK
))
3669 expand_start_cond (ffecom_truth_value
3670 (ffecom_2 (LT_EXPR
, integer_type_node
,
3672 ffecom_integer_zero_node
)),
3674 expand_goto (ffeste_io_end_
);
3678 /* "if (iostat>0) goto err_label;". */
3680 if ((ffeste_io_err_
!= NULL_TREE
)
3681 && (TREE_CODE (ffeste_io_err_
) != ERROR_MARK
))
3683 expand_start_cond (ffecom_truth_value
3684 (ffecom_2 (GT_EXPR
, integer_type_node
,
3686 ffecom_integer_zero_node
)),
3688 expand_goto (ffeste_io_err_
);
3693 ffeste_end_stmt_ ();
3696 /* WRITE statement -- start. */
3699 ffeste_R910_start (ffestpWriteStmt
*info
, ffestvUnit unit
,
3700 ffestvFormat format
, bool rec
)
3708 ffeste_check_start_ ();
3710 ffeste_emit_line_note_ ();
3712 /* First determine the start, per-item, and end run-time functions to
3713 call. The per-item function is picked by choosing an ffeste function
3714 to call to handle a given item; it knows how to generate a call to the
3715 appropriate run-time function, and is called an "I/O driver". */
3719 case FFESTV_formatNONE
: /* no FMT= */
3720 ffeste_io_driver_
= ffeste_io_douio_
;
3722 start
= FFECOM_gfrtSWDUE
, end
= FFECOM_gfrtEWDUE
;
3724 start
= FFECOM_gfrtSWSUE
, end
= FFECOM_gfrtEWSUE
;
3727 case FFESTV_formatLABEL
: /* FMT=10 */
3728 case FFESTV_formatCHAREXPR
: /* FMT='(I10)' */
3729 case FFESTV_formatINTEXPR
: /* FMT=I [after ASSIGN 10 TO I] */
3730 ffeste_io_driver_
= ffeste_io_dofio_
;
3732 start
= FFECOM_gfrtSWDFE
, end
= FFECOM_gfrtEWDFE
;
3733 else if (unit
== FFESTV_unitCHAREXPR
)
3734 start
= FFECOM_gfrtSWSFI
, end
= FFECOM_gfrtEWSFI
;
3736 start
= FFECOM_gfrtSWSFE
, end
= FFECOM_gfrtEWSFE
;
3739 case FFESTV_formatASTERISK
: /* FMT=* */
3740 ffeste_io_driver_
= ffeste_io_dolio_
;
3741 if (unit
== FFESTV_unitCHAREXPR
)
3742 start
= FFECOM_gfrtSWSLI
, end
= FFECOM_gfrtEWSLI
;
3744 start
= FFECOM_gfrtSWSLE
, end
= FFECOM_gfrtEWSLE
;
3747 case FFESTV_formatNAMELIST
: /* FMT=FOO or NML=FOO [NAMELIST
3749 ffeste_io_driver_
= NULL
; /* No start or driver function. */
3750 start
= FFECOM_gfrtSWSNE
, end
= FFECOM_gfrt
;
3754 assert ("Weird stuff" == NULL
);
3755 start
= FFECOM_gfrt
, end
= FFECOM_gfrt
;
3758 ffeste_io_endgfrt_
= end
;
3760 #define specified(something) (info->write_spec[something].kw_or_val_present)
3762 iostat
= specified (FFESTP_writeixIOSTAT
);
3763 errl
= specified (FFESTP_writeixERR
);
3767 ffeste_start_stmt_ ();
3769 ffeste_io_end_
= NULL_TREE
;
3773 /* Have ERR= specification. */
3777 = ffecom_lookup_label
3778 (info
->write_spec
[FFESTP_writeixERR
].u
.label
);
3779 ffeste_io_abort_is_temp_
= FALSE
;
3783 /* No ERR= specification. */
3785 ffeste_io_err_
= NULL_TREE
;
3787 if ((ffeste_io_abort_is_temp_
= iostat
))
3788 ffeste_io_abort_
= ffecom_temp_label ();
3790 ffeste_io_abort_
= NULL_TREE
;
3795 /* Have IOSTAT= specification. */
3797 ffeste_io_iostat_is_temp_
= FALSE
;
3798 ffeste_io_iostat_
= ffecom_expr
3799 (info
->write_spec
[FFESTP_writeixIOSTAT
].u
.expr
);
3801 else if (ffeste_io_abort_
!= NULL_TREE
)
3803 /* Have no IOSTAT= but have ERR=. */
3805 ffeste_io_iostat_is_temp_
= TRUE
;
3807 = ffecom_make_tempvar ("write", ffecom_integer_type_node
,
3808 FFETARGET_charactersizeNONE
, -1);
3812 /* No IOSTAT= or ERR= specification. */
3814 ffeste_io_iostat_is_temp_
= FALSE
;
3815 ffeste_io_iostat_
= NULL_TREE
;
3818 /* Now prescan, then convert, all the arguments. */
3820 if (unit
== FFESTV_unitCHAREXPR
)
3821 cilist
= ffeste_io_icilist_ (errl
|| iostat
,
3822 info
->write_spec
[FFESTP_writeixUNIT
].u
.expr
,
3824 &info
->write_spec
[FFESTP_writeixFORMAT
]);
3826 cilist
= ffeste_io_cilist_ (errl
|| iostat
, unit
,
3827 info
->write_spec
[FFESTP_writeixUNIT
].u
.expr
,
3829 &info
->write_spec
[FFESTP_writeixFORMAT
],
3831 info
->write_spec
[FFESTP_writeixREC
].u
.expr
);
3833 /* If there is no end function, then there are no item functions (i.e.
3834 it's a NAMELIST), and vice versa by the way. In this situation, don't
3835 generate the "if (iostat != 0) goto label;" if the label is temp abort
3836 label, since we're gonna fall through to there anyway. */
3838 ffeste_io_call_ (ffecom_call_gfrt (start
, cilist
, NULL_TREE
),
3839 (! ffeste_io_abort_is_temp_
) || (end
!= FFECOM_gfrt
));
3842 /* WRITE statement -- I/O item. */
3845 ffeste_R910_item (ffebld expr
, ffelexToken expr_token
)
3847 ffeste_check_item_ ();
3852 if (ffebld_op (expr
) == FFEBLD_opANY
)
3855 if (ffebld_op (expr
) == FFEBLD_opIMPDO
)
3856 ffeste_io_impdo_ (expr
, expr_token
);
3859 ffeste_start_stmt_ ();
3861 ffecom_prepare_arg_ptr_to_expr (expr
);
3863 ffecom_prepare_end ();
3865 ffeste_io_call_ ((*ffeste_io_driver_
) (expr
), TRUE
);
3867 ffeste_end_stmt_ ();
3871 /* WRITE statement -- end. */
3874 ffeste_R910_finish ()
3876 ffeste_check_finish_ ();
3878 /* Don't generate "if (iostat != 0) goto label;" if label is temp abort
3879 label, since we're gonna fall through to there anyway. */
3881 if (ffeste_io_endgfrt_
!= FFECOM_gfrt
)
3882 ffeste_io_call_ (ffecom_call_gfrt (ffeste_io_endgfrt_
, NULL_TREE
,
3884 ! ffeste_io_abort_is_temp_
);
3886 /* If we've got a temp label, generate its code here. */
3888 if (ffeste_io_abort_is_temp_
)
3890 DECL_INITIAL (ffeste_io_abort_
) = error_mark_node
;
3892 expand_label (ffeste_io_abort_
);
3894 assert (ffeste_io_err_
== NULL_TREE
);
3897 ffeste_end_stmt_ ();
3900 /* PRINT statement -- start. */
3903 ffeste_R911_start (ffestpPrintStmt
*info
, ffestvFormat format
)
3909 ffeste_check_start_ ();
3911 ffeste_emit_line_note_ ();
3913 /* First determine the start, per-item, and end run-time functions to
3914 call. The per-item function is picked by choosing an ffeste function
3915 to call to handle a given item; it knows how to generate a call to the
3916 appropriate run-time function, and is called an "I/O driver". */
3920 case FFESTV_formatLABEL
: /* FMT=10 */
3921 case FFESTV_formatCHAREXPR
: /* FMT='(I10)' */
3922 case FFESTV_formatINTEXPR
: /* FMT=I [after ASSIGN 10 TO I] */
3923 ffeste_io_driver_
= ffeste_io_dofio_
;
3924 start
= FFECOM_gfrtSWSFE
, end
= FFECOM_gfrtEWSFE
;
3927 case FFESTV_formatASTERISK
: /* FMT=* */
3928 ffeste_io_driver_
= ffeste_io_dolio_
;
3929 start
= FFECOM_gfrtSWSLE
, end
= FFECOM_gfrtEWSLE
;
3932 case FFESTV_formatNAMELIST
: /* FMT=FOO or NML=FOO [NAMELIST
3934 ffeste_io_driver_
= NULL
; /* No start or driver function. */
3935 start
= FFECOM_gfrtSWSNE
, end
= FFECOM_gfrt
;
3939 assert ("Weird stuff" == NULL
);
3940 start
= FFECOM_gfrt
, end
= FFECOM_gfrt
;
3943 ffeste_io_endgfrt_
= end
;
3945 ffeste_start_stmt_ ();
3947 ffeste_io_end_
= NULL_TREE
;
3948 ffeste_io_err_
= NULL_TREE
;
3949 ffeste_io_abort_
= NULL_TREE
;
3950 ffeste_io_abort_is_temp_
= FALSE
;
3951 ffeste_io_iostat_is_temp_
= FALSE
;
3952 ffeste_io_iostat_
= NULL_TREE
;
3954 /* Now prescan, then convert, all the arguments. */
3956 cilist
= ffeste_io_cilist_ (FALSE
, FFESTV_unitNONE
, NULL
, 6, FALSE
, format
,
3957 &info
->print_spec
[FFESTP_printixFORMAT
],
3960 /* If there is no end function, then there are no item functions (i.e.
3961 it's a NAMELIST), and vice versa by the way. In this situation, don't
3962 generate the "if (iostat != 0) goto label;" if the label is temp abort
3963 label, since we're gonna fall through to there anyway. */
3965 ffeste_io_call_ (ffecom_call_gfrt (start
, cilist
, NULL_TREE
),
3966 (! ffeste_io_abort_is_temp_
) || (end
!= FFECOM_gfrt
));
3969 /* PRINT statement -- I/O item. */
3972 ffeste_R911_item (ffebld expr
, ffelexToken expr_token
)
3974 ffeste_check_item_ ();
3979 if (ffebld_op (expr
) == FFEBLD_opANY
)
3982 if (ffebld_op (expr
) == FFEBLD_opIMPDO
)
3983 ffeste_io_impdo_ (expr
, expr_token
);
3986 ffeste_start_stmt_ ();
3988 ffecom_prepare_arg_ptr_to_expr (expr
);
3990 ffecom_prepare_end ();
3992 ffeste_io_call_ ((*ffeste_io_driver_
) (expr
), TRUE
);
3994 ffeste_end_stmt_ ();
3998 /* PRINT statement -- end. */
4001 ffeste_R911_finish ()
4003 ffeste_check_finish_ ();
4005 if (ffeste_io_endgfrt_
!= FFECOM_gfrt
)
4006 ffeste_io_call_ (ffecom_call_gfrt (ffeste_io_endgfrt_
, NULL_TREE
,
4010 ffeste_end_stmt_ ();
4013 /* BACKSPACE statement. */
4016 ffeste_R919 (ffestpBeruStmt
*info
)
4018 ffeste_check_simple_ ();
4020 ffeste_subr_beru_ (info
, FFECOM_gfrtFBACK
);
4023 /* ENDFILE statement. */
4026 ffeste_R920 (ffestpBeruStmt
*info
)
4028 ffeste_check_simple_ ();
4030 ffeste_subr_beru_ (info
, FFECOM_gfrtFEND
);
4033 /* REWIND statement. */
4036 ffeste_R921 (ffestpBeruStmt
*info
)
4038 ffeste_check_simple_ ();
4040 ffeste_subr_beru_ (info
, FFECOM_gfrtFREW
);
4043 /* INQUIRE statement (non-IOLENGTH version). */
4046 ffeste_R923A (ffestpInquireStmt
*info
, bool by_file UNUSED
)
4052 ffeste_check_simple_ ();
4054 ffeste_emit_line_note_ ();
4056 #define specified(something) (info->inquire_spec[something].kw_or_val_present)
4058 iostat
= specified (FFESTP_inquireixIOSTAT
);
4059 errl
= specified (FFESTP_inquireixERR
);
4063 ffeste_start_stmt_ ();
4069 = ffecom_lookup_label
4070 (info
->inquire_spec
[FFESTP_inquireixERR
].u
.label
);
4071 ffeste_io_abort_is_temp_
= FALSE
;
4075 ffeste_io_err_
= NULL_TREE
;
4077 if ((ffeste_io_abort_is_temp_
= iostat
))
4078 ffeste_io_abort_
= ffecom_temp_label ();
4080 ffeste_io_abort_
= NULL_TREE
;
4085 /* Have IOSTAT= specification. */
4087 ffeste_io_iostat_is_temp_
= FALSE
;
4088 ffeste_io_iostat_
= ffecom_expr
4089 (info
->inquire_spec
[FFESTP_inquireixIOSTAT
].u
.expr
);
4091 else if (ffeste_io_abort_
!= NULL_TREE
)
4093 /* Have no IOSTAT= but have ERR=. */
4095 ffeste_io_iostat_is_temp_
= TRUE
;
4097 = ffecom_make_tempvar ("inquire", ffecom_integer_type_node
,
4098 FFETARGET_charactersizeNONE
, -1);
4102 /* No IOSTAT= or ERR= specification. */
4104 ffeste_io_iostat_is_temp_
= FALSE
;
4105 ffeste_io_iostat_
= NULL_TREE
;
4108 /* Now prescan, then convert, all the arguments. */
4111 = ffeste_io_inlist_ (errl
|| iostat
,
4112 &info
->inquire_spec
[FFESTP_inquireixUNIT
],
4113 &info
->inquire_spec
[FFESTP_inquireixFILE
],
4114 &info
->inquire_spec
[FFESTP_inquireixEXIST
],
4115 &info
->inquire_spec
[FFESTP_inquireixOPENED
],
4116 &info
->inquire_spec
[FFESTP_inquireixNUMBER
],
4117 &info
->inquire_spec
[FFESTP_inquireixNAMED
],
4118 &info
->inquire_spec
[FFESTP_inquireixNAME
],
4119 &info
->inquire_spec
[FFESTP_inquireixACCESS
],
4120 &info
->inquire_spec
[FFESTP_inquireixSEQUENTIAL
],
4121 &info
->inquire_spec
[FFESTP_inquireixDIRECT
],
4122 &info
->inquire_spec
[FFESTP_inquireixFORM
],
4123 &info
->inquire_spec
[FFESTP_inquireixFORMATTED
],
4124 &info
->inquire_spec
[FFESTP_inquireixUNFORMATTED
],
4125 &info
->inquire_spec
[FFESTP_inquireixRECL
],
4126 &info
->inquire_spec
[FFESTP_inquireixNEXTREC
],
4127 &info
->inquire_spec
[FFESTP_inquireixBLANK
]);
4129 /* Don't generate "if (iostat != 0) goto label;" if label is temp abort
4130 label, since we're gonna fall through to there anyway. */
4132 ffeste_io_call_ (ffecom_call_gfrt (FFECOM_gfrtFINQU
, args
, NULL_TREE
),
4133 ! ffeste_io_abort_is_temp_
);
4135 /* If we've got a temp label, generate its code here. */
4137 if (ffeste_io_abort_is_temp_
)
4139 DECL_INITIAL (ffeste_io_abort_
) = error_mark_node
;
4141 expand_label (ffeste_io_abort_
);
4143 assert (ffeste_io_err_
== NULL_TREE
);
4146 ffeste_end_stmt_ ();
4149 /* INQUIRE(IOLENGTH=expr) statement -- start. */
4152 ffeste_R923B_start (ffestpInquireStmt
*info UNUSED
)
4154 ffeste_check_start_ ();
4156 assert ("INQUIRE(IOLENGTH=<var>) not implemented yet! ~~~" == NULL
);
4158 ffeste_emit_line_note_ ();
4161 /* INQUIRE(IOLENGTH=expr) statement -- I/O item. */
4164 ffeste_R923B_item (ffebld expr UNUSED
)
4166 ffeste_check_item_ ();
4169 /* INQUIRE(IOLENGTH=expr) statement -- end. */
4172 ffeste_R923B_finish ()
4174 ffeste_check_finish_ ();
4177 /* ffeste_R1001 -- FORMAT statement
4179 ffeste_R1001(format_list); */
4182 ffeste_R1001 (ffests s
)
4189 ffeste_check_simple_ ();
4191 assert (ffeste_label_formatdef_
!= NULL
);
4193 ffeste_emit_line_note_ ();
4195 t
= build_string (ffests_length (s
), ffests_text (s
));
4198 = build_type_variant (build_array_type
4200 build_range_type (integer_type_node
,
4202 build_int_2 (ffests_length (s
),
4205 TREE_CONSTANT (t
) = 1;
4206 TREE_STATIC (t
) = 1;
4208 var
= ffecom_lookup_label (ffeste_label_formatdef_
);
4209 if ((var
!= NULL_TREE
)
4210 && (TREE_CODE (var
) == VAR_DECL
))
4212 DECL_INITIAL (var
) = t
;
4213 maxindex
= build_int_2 (ffests_length (s
) - 1, 0);
4214 ttype
= TREE_TYPE (var
);
4215 TYPE_DOMAIN (ttype
) = build_range_type (integer_type_node
,
4218 if (!TREE_TYPE (maxindex
))
4219 TREE_TYPE (maxindex
) = TYPE_DOMAIN (ttype
);
4220 layout_type (ttype
);
4221 rest_of_decl_compilation (var
, NULL
, 1, 0);
4223 expand_decl_init (var
);
4226 ffeste_label_formatdef_
= NULL
;
4236 /* END BLOCK DATA. */
4243 /* CALL statement. */
4246 ffeste_R1212 (ffebld expr
)
4250 ffebld labels
= NULL
; /* First in list of LABTERs. */
4251 ffebld prevlabels
= NULL
;
4252 ffebld prevargs
= NULL
;
4254 ffeste_check_simple_ ();
4256 args
= ffebld_right (expr
);
4258 ffeste_emit_line_note_ ();
4260 /* Here we split the list at ffebld_right(expr) into two lists: one at
4261 ffebld_right(expr) consisting of all items that are not LABTERs, the
4262 other at labels consisting of all items that are LABTERs. Then, if
4263 the latter list is NULL, we have an ordinary call, else we have a call
4264 with alternate returns. */
4266 for (args
= ffebld_right (expr
); args
!= NULL
; args
= ffebld_trail (args
))
4268 if (((arg
= ffebld_head (args
)) == NULL
)
4269 || (ffebld_op (arg
) != FFEBLD_opLABTER
))
4271 if (prevargs
== NULL
)
4274 ffebld_set_right (expr
, args
);
4278 ffebld_set_trail (prevargs
, args
);
4284 if (prevlabels
== NULL
)
4286 prevlabels
= labels
= args
;
4290 ffebld_set_trail (prevlabels
, args
);
4295 if (prevlabels
== NULL
)
4298 ffebld_set_trail (prevlabels
, NULL
);
4299 if (prevargs
== NULL
)
4300 ffebld_set_right (expr
, NULL
);
4302 ffebld_set_trail (prevargs
, NULL
);
4304 ffeste_start_stmt_ ();
4306 /* No temporaries are actually needed at this level, but we go
4307 through the motions anyway, just to be sure in case they do
4308 get made. Temporaries needed for arguments should be in the
4309 scopes of inner blocks, and if clean-up actions are supported,
4310 such as CALL-ing an intrinsic that writes to an argument of one
4311 type when a variable of a different type is provided (requiring
4312 assignment to the variable from a temporary after the library
4313 routine returns), the clean-up must be done by the expression
4314 evaluator, generally, to handle alternate returns (which we hope
4315 won't ever be supported by intrinsics, but might be a similar
4316 issue, such as CALL-ing an F90-style subroutine with an INTERFACE
4317 block). That implies the expression evaluator will have to
4318 recognize the need for its own temporary anyway, meaning it'll
4319 construct a block within the one constructed here. */
4321 ffecom_prepare_expr (expr
);
4323 ffecom_prepare_end ();
4326 expand_expr_stmt (ffecom_expr (expr
));
4337 texpr
= ffecom_expr (expr
);
4338 expand_start_case (0, texpr
, TREE_TYPE (texpr
), "CALL statement");
4340 for (caseno
= 1, label
= labels
;
4342 ++caseno
, label
= ffebld_trail (label
))
4344 value
= build_int_2 (caseno
, 0);
4345 tlabel
= build_decl (LABEL_DECL
, NULL_TREE
, NULL_TREE
);
4347 pushok
= pushcase (value
, convert
, tlabel
, &duplicate
);
4348 assert (pushok
== 0);
4351 = ffecom_lookup_label (ffebld_labter (ffebld_head (label
)));
4352 if ((tlabel
== NULL_TREE
)
4353 || (TREE_CODE (tlabel
) == ERROR_MARK
))
4355 TREE_USED (tlabel
) = 1;
4356 expand_goto (tlabel
);
4359 expand_end_case (texpr
);
4362 ffeste_end_stmt_ ();
4372 /* END SUBROUTINE. */
4379 /* ENTRY statement. */
4382 ffeste_R1226 (ffesymbol entry
)
4386 ffeste_check_simple_ ();
4388 label
= ffesymbol_hook (entry
).length_tree
;
4390 ffeste_emit_line_note_ ();
4392 if (label
== error_mark_node
)
4395 DECL_INITIAL (label
) = error_mark_node
;
4397 expand_label (label
);
4400 /* RETURN statement. */
4403 ffeste_R1227 (ffestw block UNUSED
, ffebld expr
)
4407 ffeste_check_simple_ ();
4409 ffeste_emit_line_note_ ();
4411 ffeste_start_stmt_ ();
4413 ffecom_prepare_return_expr (expr
);
4415 ffecom_prepare_end ();
4417 rtn
= ffecom_return_expr (expr
);
4419 if ((rtn
== NULL_TREE
)
4420 || (rtn
== error_mark_node
))
4421 expand_null_return ();
4424 tree result
= DECL_RESULT (current_function_decl
);
4426 if ((result
!= error_mark_node
)
4427 && (TREE_TYPE (result
) != error_mark_node
))
4428 expand_return (ffecom_modify (NULL_TREE
,
4430 convert (TREE_TYPE (result
),
4433 expand_null_return ();
4436 ffeste_end_stmt_ ();
4439 /* REWRITE statement -- start. */
4443 ffeste_V018_start (ffestpRewriteStmt
*info
, ffestvFormat format
)
4445 ffeste_check_start_ ();
4448 /* REWRITE statement -- I/O item. */
4451 ffeste_V018_item (ffebld expr
)
4453 ffeste_check_item_ ();
4456 /* REWRITE statement -- end. */
4459 ffeste_V018_finish ()
4461 ffeste_check_finish_ ();
4464 /* ACCEPT statement -- start. */
4467 ffeste_V019_start (ffestpAcceptStmt
*info
, ffestvFormat format
)
4469 ffeste_check_start_ ();
4472 /* ACCEPT statement -- I/O item. */
4475 ffeste_V019_item (ffebld expr
)
4477 ffeste_check_item_ ();
4480 /* ACCEPT statement -- end. */
4483 ffeste_V019_finish ()
4485 ffeste_check_finish_ ();
4489 /* TYPE statement -- start. */
4492 ffeste_V020_start (ffestpTypeStmt
*info UNUSED
,
4493 ffestvFormat format UNUSED
)
4495 ffeste_check_start_ ();
4498 /* TYPE statement -- I/O item. */
4501 ffeste_V020_item (ffebld expr UNUSED
)
4503 ffeste_check_item_ ();
4506 /* TYPE statement -- end. */
4509 ffeste_V020_finish ()
4511 ffeste_check_finish_ ();
4514 /* DELETE statement. */
4518 ffeste_V021 (ffestpDeleteStmt
*info
)
4520 ffeste_check_simple_ ();
4523 /* UNLOCK statement. */
4526 ffeste_V022 (ffestpBeruStmt
*info
)
4528 ffeste_check_simple_ ();
4531 /* ENCODE statement -- start. */
4534 ffeste_V023_start (ffestpVxtcodeStmt
*info
)
4536 ffeste_check_start_ ();
4539 /* ENCODE statement -- I/O item. */
4542 ffeste_V023_item (ffebld expr
)
4544 ffeste_check_item_ ();
4547 /* ENCODE statement -- end. */
4550 ffeste_V023_finish ()
4552 ffeste_check_finish_ ();
4555 /* DECODE statement -- start. */
4558 ffeste_V024_start (ffestpVxtcodeStmt
*info
)
4560 ffeste_check_start_ ();
4563 /* DECODE statement -- I/O item. */
4566 ffeste_V024_item (ffebld expr
)
4568 ffeste_check_item_ ();
4571 /* DECODE statement -- end. */
4574 ffeste_V024_finish ()
4576 ffeste_check_finish_ ();
4579 /* DEFINEFILE statement -- start. */
4582 ffeste_V025_start ()
4584 ffeste_check_start_ ();
4587 /* DEFINE FILE statement -- item. */
4590 ffeste_V025_item (ffebld u
, ffebld m
, ffebld n
, ffebld asv
)
4592 ffeste_check_item_ ();
4595 /* DEFINE FILE statement -- end. */
4598 ffeste_V025_finish ()
4600 ffeste_check_finish_ ();
4603 /* FIND statement. */
4606 ffeste_V026 (ffestpFindStmt
*info
)
4608 ffeste_check_simple_ ();
4613 #ifdef ENABLE_CHECKING
4615 ffeste_terminate_2 (void)
4617 assert (! ffeste_top_block_
);