1 /* ste.c -- Implementation File (module.c template V1.0)
2 Copyright (C) 1995, 1996, 2000, 2002, 2003 Free Software Foundation, Inc.
3 Contributed by James Craig Burley.
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, input_line)
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
;
394 gbe_block ffeste_top_block_
= NULL
;
397 ffeste_start_block_ (ffestw block
)
399 gbe_block b
= xmalloc (sizeof (*b
));
401 b
->outer
= ffeste_top_block_
;
403 b
->location
= input_location
;
406 ffeste_top_block_
= b
;
408 ffecom_start_compstmt ();
411 /* End a Fortran block. */
414 ffeste_end_block_ (ffestw block
)
416 gbe_block b
= ffeste_top_block_
;
419 assert (! b
->is_stmt
);
420 assert (b
->block
== block
);
421 assert (! b
->is_stmt
);
423 ffeste_top_block_
= b
->outer
;
427 ffecom_end_compstmt ();
430 /* Start a Fortran statement.
432 Starts a back-end block, so temporaries can be managed, clean-ups
433 properly handled, etc. Nesting of statements *is* allowed -- the
434 handling of I/O items, even implied-DO I/O lists, within a READ,
435 PRINT, or WRITE statement is one example. */
438 ffeste_start_stmt_(void)
440 gbe_block b
= xmalloc (sizeof (*b
));
442 b
->outer
= ffeste_top_block_
;
444 b
->location
= input_location
;
447 ffeste_top_block_
= b
;
449 ffecom_start_compstmt ();
452 /* End a Fortran statement. */
455 ffeste_end_stmt_(void)
457 gbe_block b
= ffeste_top_block_
;
462 ffeste_top_block_
= b
->outer
;
466 ffecom_end_compstmt ();
469 #else /* ! defined (ENABLE_CHECKING) */
471 #define ffeste_start_block_(b) ffecom_start_compstmt ()
472 #define ffeste_end_block_(b) \
475 ffecom_end_compstmt (); \
477 #define ffeste_start_stmt_() ffeste_start_block_(NULL)
478 #define ffeste_end_stmt_() ffeste_end_block_(NULL)
480 #endif /* ! defined (ENABLE_CHECKING) */
482 /* Begin an iterative DO loop. Pass the block to start if
486 ffeste_begin_iterdo_ (ffestw block
, tree
*xtvar
, tree
*xtincr
,
487 tree
*xitersvar
, ffebld var
,
488 ffebld start
, ffelexToken start_token
,
489 ffebld end
, ffelexToken end_token
,
490 ffebld incr
, ffelexToken incr_token
,
500 struct nesting
*expanded_loop
;
502 /* Want to have tvar, tincr, and niters for the whole loop body. */
505 ffeste_start_block_ (block
);
507 ffeste_start_stmt_ ();
509 niters
= ffecom_make_tempvar (block
? "do" : "impdo",
510 ffecom_integer_type_node
,
511 FFETARGET_charactersizeNONE
, -1);
513 ffecom_prepare_expr (incr
);
514 ffecom_prepare_expr_rw (NULL_TREE
, var
);
516 ffecom_prepare_end ();
518 tvar
= ffecom_expr_rw (NULL_TREE
, var
);
519 tincr
= ffecom_expr (incr
);
521 if (TREE_CODE (tvar
) == ERROR_MARK
522 || TREE_CODE (tincr
) == ERROR_MARK
)
526 ffeste_end_block_ (block
);
527 ffestw_set_do_tvar (block
, error_mark_node
);
532 *xtvar
= error_mark_node
;
537 /* Check whether incr is known to be zero, complain and fix. */
539 if (integer_zerop (tincr
) || real_zerop (tincr
))
541 ffebad_start (FFEBAD_DO_STEP_ZERO
);
542 ffebad_here (0, ffelex_token_where_line (incr_token
),
543 ffelex_token_where_column (incr_token
));
546 tincr
= convert (TREE_TYPE (tvar
), integer_one_node
);
549 tincr_saved
= ffecom_save_tree (tincr
);
551 /* Want to have tstart, tend for just this statement. */
553 ffeste_start_stmt_ ();
555 ffecom_prepare_expr (start
);
556 ffecom_prepare_expr (end
);
558 ffecom_prepare_end ();
560 tstart
= ffecom_expr (start
);
561 tend
= ffecom_expr (end
);
563 if (TREE_CODE (tstart
) == ERROR_MARK
564 || TREE_CODE (tend
) == ERROR_MARK
)
570 ffeste_end_block_ (block
);
571 ffestw_set_do_tvar (block
, error_mark_node
);
576 *xtvar
= error_mark_node
;
581 /* For warnings only, nothing else happens here. */
585 if (! ffe_is_onetrip ())
587 try = ffecom_2 (MINUS_EXPR
, TREE_TYPE (tvar
),
591 try = ffecom_2 (PLUS_EXPR
, TREE_TYPE (tvar
),
595 if (TREE_CODE (TREE_TYPE (tvar
)) != REAL_TYPE
)
596 try = ffecom_2 (TRUNC_DIV_EXPR
, integer_type_node
, try,
599 try = convert (integer_type_node
,
600 ffecom_2 (RDIV_EXPR
, TREE_TYPE (tvar
),
604 /* Warn if loop never executed, since we've done the evaluation
605 of the unofficial iteration count already. */
607 try = ffecom_truth_value (ffecom_2 (LE_EXPR
, integer_type_node
,
609 convert (TREE_TYPE (tvar
),
610 integer_zero_node
)));
612 if (integer_onep (try))
614 ffebad_start (FFEBAD_DO_NULL
);
615 ffebad_here (0, ffelex_token_where_line (start_token
),
616 ffelex_token_where_column (start_token
));
622 /* Warn if end plus incr would overflow. */
624 try = ffecom_2 (PLUS_EXPR
, TREE_TYPE (tvar
),
628 if ((TREE_CODE_CLASS (TREE_CODE (try)) == 'c')
629 && TREE_CONSTANT_OVERFLOW (try))
631 ffebad_start (FFEBAD_DO_END_OVERFLOW
);
632 ffebad_here (0, ffelex_token_where_line (end_token
),
633 ffelex_token_where_column (end_token
));
639 /* Do the initial assignment into the DO var. */
641 tstart
= ffecom_save_tree (tstart
);
643 expr
= ffecom_2 (MINUS_EXPR
, TREE_TYPE (tvar
),
647 if (! ffe_is_onetrip ())
649 expr
= ffecom_2 (PLUS_EXPR
, TREE_TYPE (expr
),
651 convert (TREE_TYPE (expr
), tincr_saved
));
654 if (TREE_CODE (TREE_TYPE (tvar
)) != REAL_TYPE
)
655 expr
= ffecom_2 (TRUNC_DIV_EXPR
, TREE_TYPE (expr
),
659 expr
= ffecom_2 (RDIV_EXPR
, TREE_TYPE (expr
),
663 #if 1 /* New, F90-approved approach: convert to default INTEGER. */
664 if (TREE_TYPE (tvar
) != error_mark_node
)
665 expr
= convert (ffecom_integer_type_node
, expr
);
666 #else /* Old approach; convert to INTEGER unless that's a narrowing. */
667 if ((TREE_TYPE (tvar
) != error_mark_node
)
668 && ((TREE_CODE (TREE_TYPE (tvar
)) != INTEGER_TYPE
)
669 || ((TYPE_SIZE (TREE_TYPE (tvar
)) != NULL_TREE
)
670 && ((TREE_CODE (TYPE_SIZE (TREE_TYPE (tvar
)))
672 || (TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (tvar
)))
673 <= TREE_INT_CST_LOW (TYPE_SIZE (ffecom_integer_type_node
)))))))
674 /* Convert unless promoting INTEGER type of any kind downward to
675 default INTEGER; else leave as, say, INTEGER*8 (long long int). */
676 expr
= convert (ffecom_integer_type_node
, expr
);
679 assert (TYPE_MAIN_VARIANT (TREE_TYPE (niters
))
680 == TYPE_MAIN_VARIANT (TREE_TYPE (expr
)));
682 expr
= ffecom_modify (void_type_node
, niters
, expr
);
683 expand_expr_stmt (expr
);
685 expr
= ffecom_modify (void_type_node
, tvar
, tstart
);
686 expand_expr_stmt (expr
);
690 expanded_loop
= expand_start_loop_continue_elsewhere (!! block
);
692 ffestw_set_do_hook (block
, expanded_loop
);
694 if (! ffe_is_onetrip ())
696 expr
= ffecom_truth_value
697 (ffecom_2 (GE_EXPR
, integer_type_node
,
698 ffecom_2 (PREDECREMENT_EXPR
,
701 convert (TREE_TYPE (niters
),
702 ffecom_integer_one_node
)),
703 convert (TREE_TYPE (niters
),
704 ffecom_integer_zero_node
)));
706 expand_exit_loop_top_cond (0, expr
);
711 ffestw_set_do_tvar (block
, tvar
);
712 ffestw_set_do_incr_saved (block
, tincr_saved
);
713 ffestw_set_do_count_var (block
, niters
);
718 *xtincr
= tincr_saved
;
723 /* End an iterative DO loop. Pass the same iteration variable and increment
724 value trees that were generated in the paired _begin_ call. */
727 ffeste_end_iterdo_ (ffestw block
, tree tvar
, tree tincr
, tree itersvar
)
730 tree niters
= itersvar
;
732 if (tvar
== error_mark_node
)
735 expand_loop_continue_here ();
737 ffeste_start_stmt_ ();
739 if (ffe_is_onetrip ())
741 expr
= ffecom_truth_value
742 (ffecom_2 (GE_EXPR
, integer_type_node
,
743 ffecom_2 (PREDECREMENT_EXPR
,
746 convert (TREE_TYPE (niters
),
747 ffecom_integer_one_node
)),
748 convert (TREE_TYPE (niters
),
749 ffecom_integer_zero_node
)));
751 expand_exit_loop_if_false (0, expr
);
754 expr
= ffecom_modify (void_type_node
, tvar
,
755 ffecom_2 (PLUS_EXPR
, TREE_TYPE (tvar
),
758 expand_expr_stmt (expr
);
760 /* Lose the stuff we just built. */
765 /* Lose the tvar and incr_saved trees. */
767 ffeste_end_block_ (block
);
772 /* Generate call to run-time I/O routine. */
775 ffeste_io_call_ (tree call
, bool do_check
)
777 /* Generate the call and optional assignment into iostat var. */
779 TREE_SIDE_EFFECTS (call
) = 1;
780 if (ffeste_io_iostat_
!= NULL_TREE
)
781 call
= ffecom_modify (do_check
? NULL_TREE
: void_type_node
,
782 ffeste_io_iostat_
, call
);
783 expand_expr_stmt (call
);
786 || ffeste_io_abort_
== NULL_TREE
787 || TREE_CODE (ffeste_io_abort_
) == ERROR_MARK
)
790 /* Generate optional test. */
792 expand_start_cond (ffecom_truth_value (ffeste_io_iostat_
), 0);
793 expand_goto (ffeste_io_abort_
);
797 /* Handle implied-DO in I/O list.
799 Expands code to start up the DO loop. Then for each item in the
800 DO loop, handles appropriately (possibly including recursively calling
801 itself). Then expands code to end the DO loop. */
804 ffeste_io_impdo_ (ffebld impdo
, ffelexToken impdo_token
)
806 ffebld var
= ffebld_head (ffebld_right (impdo
));
807 ffebld start
= ffebld_head (ffebld_trail (ffebld_right (impdo
)));
808 ffebld end
= ffebld_head (ffebld_trail (ffebld_trail
809 (ffebld_right (impdo
))));
810 ffebld incr
= ffebld_head (ffebld_trail (ffebld_trail
811 (ffebld_trail (ffebld_right (impdo
)))));
820 incr
= ffebld_new_conter (ffebld_constant_new_integerdefault_val (1));
821 ffebld_set_info (incr
, ffeinfo_new
822 (FFEINFO_basictypeINTEGER
,
823 FFEINFO_kindtypeINTEGERDEFAULT
,
826 FFEINFO_whereCONSTANT
,
827 FFETARGET_charactersizeNONE
));
830 /* Start the DO loop. */
832 start
= ffeexpr_convert_expr (start
, impdo_token
, var
, impdo_token
,
834 end
= ffeexpr_convert_expr (end
, impdo_token
, var
, impdo_token
,
836 incr
= ffeexpr_convert_expr (incr
, impdo_token
, var
, impdo_token
,
839 ffeste_begin_iterdo_ (NULL
, &tvar
, &tincr
, &titervar
, var
,
845 /* Handle the list of items. */
847 for (list
= ffebld_left (impdo
); list
!= NULL
; list
= ffebld_trail (list
))
849 item
= ffebld_head (list
);
853 /* Strip parens off items such as in "READ *,(A)". This is really a bug
854 in the user's code, but I've been told lots of code does this. */
855 while (ffebld_op (item
) == FFEBLD_opPAREN
)
856 item
= ffebld_left (item
);
858 if (ffebld_op (item
) == FFEBLD_opANY
)
861 if (ffebld_op (item
) == FFEBLD_opIMPDO
)
862 ffeste_io_impdo_ (item
, impdo_token
);
865 ffeste_start_stmt_ ();
867 ffecom_prepare_arg_ptr_to_expr (item
);
869 ffecom_prepare_end ();
871 ffeste_io_call_ ((*ffeste_io_driver_
) (item
), TRUE
);
877 /* Generate end of implied-do construct. */
879 ffeste_end_iterdo_ (NULL
, tvar
, tincr
, titervar
);
882 /* I/O driver for formatted I/O item (do_fio)
884 Returns a tree for a CALL_EXPR to the do_fio function, which handles
885 a formatted I/O list item, along with the appropriate arguments for
886 the function. It is up to the caller to set the TREE_SIDE_EFFECTS flag
887 for the CALL_EXPR, expand (emit) the expression, emit any assignment
888 of the result to an IOSTAT= variable, and emit any checking of the
889 result for errors. */
892 ffeste_io_dofio_ (ffebld expr
)
902 bt
= ffeinfo_basictype (ffebld_info (expr
));
903 kt
= ffeinfo_kindtype (ffebld_info (expr
));
905 if ((bt
== FFEINFO_basictypeANY
)
906 || (kt
== FFEINFO_kindtypeANY
))
907 return error_mark_node
;
909 if (bt
== FFEINFO_basictypeCOMPLEX
)
912 bt
= FFEINFO_basictypeREAL
;
917 variable
= ffecom_arg_ptr_to_expr (expr
, &size
);
919 if ((variable
== error_mark_node
)
920 || (size
== error_mark_node
))
921 return error_mark_node
;
923 if (size
== NULL_TREE
) /* Already filled in for CHARACTER type. */
924 { /* "(ftnlen) sizeof(type)" */
925 size
= size_binop (CEIL_DIV_EXPR
,
926 TYPE_SIZE_UNIT (ffecom_tree_type
[bt
][kt
]),
927 size_int (TYPE_PRECISION (char_type_node
)
929 #if 0 /* Assume that while it is possible that char * is wider than
930 ftnlen, no object in Fortran space can get big enough for its
931 size to be wider than ftnlen. I really hope nobody wastes
932 time debugging a case where it can! */
933 assert (TYPE_PRECISION (ffecom_f2c_ftnlen_type_node
)
934 >= TYPE_PRECISION (TREE_TYPE (size
)));
936 size
= convert (ffecom_f2c_ftnlen_type_node
, size
);
939 if (ffeinfo_rank (ffebld_info (expr
)) == 0
940 || TREE_CODE (TREE_TYPE (TREE_TYPE (variable
))) != ARRAY_TYPE
)
942 = is_complex
? ffecom_f2c_ftnlen_two_node
: ffecom_f2c_ftnlen_one_node
;
946 = size_binop (CEIL_DIV_EXPR
,
947 TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (variable
))),
948 convert (sizetype
, size
));
949 num_elements
= size_binop (CEIL_DIV_EXPR
, num_elements
,
950 size_int (TYPE_PRECISION (char_type_node
)
952 num_elements
= convert (ffecom_f2c_ftnlen_type_node
,
957 = ffecom_1 (ADDR_EXPR
, ffecom_f2c_ptr_to_ftnlen_type_node
,
960 variable
= convert (string_type_node
, variable
);
962 arglist
= build_tree_list (NULL_TREE
, num_elements
);
963 TREE_CHAIN (arglist
) = build_tree_list (NULL_TREE
, variable
);
964 TREE_CHAIN (TREE_CHAIN (arglist
)) = build_tree_list (NULL_TREE
, size
);
966 return ffecom_call_gfrt (FFECOM_gfrtDOFIO
, arglist
, NULL_TREE
);
969 /* I/O driver for list-directed I/O item (do_lio)
971 Returns a tree for a CALL_EXPR to the do_lio function, which handles
972 a list-directed I/O list item, along with the appropriate arguments for
973 the function. It is up to the caller to set the TREE_SIDE_EFFECTS flag
974 for the CALL_EXPR, expand (emit) the expression, emit any assignment
975 of the result to an IOSTAT= variable, and emit any checking of the
976 result for errors. */
979 ffeste_io_dolio_ (ffebld expr
)
990 bt
= ffeinfo_basictype (ffebld_info (expr
));
991 kt
= ffeinfo_kindtype (ffebld_info (expr
));
993 if ((bt
== FFEINFO_basictypeANY
)
994 || (kt
== FFEINFO_kindtypeANY
))
995 return error_mark_node
;
997 tc
= ffecom_f2c_typecode (bt
, kt
);
999 type_id
= build_int_2 (tc
, 0);
1002 = ffecom_1 (ADDR_EXPR
, ffecom_f2c_ptr_to_ftnint_type_node
,
1003 convert (ffecom_f2c_ftnint_type_node
,
1006 variable
= ffecom_arg_ptr_to_expr (expr
, &size
);
1008 if ((type_id
== error_mark_node
)
1009 || (variable
== error_mark_node
)
1010 || (size
== error_mark_node
))
1011 return error_mark_node
;
1013 if (size
== NULL_TREE
) /* Already filled in for CHARACTER type. */
1014 { /* "(ftnlen) sizeof(type)" */
1015 size
= size_binop (CEIL_DIV_EXPR
,
1016 TYPE_SIZE_UNIT (ffecom_tree_type
[bt
][kt
]),
1017 size_int (TYPE_PRECISION (char_type_node
)
1019 #if 0 /* Assume that while it is possible that char * is wider than
1020 ftnlen, no object in Fortran space can get big enough for its
1021 size to be wider than ftnlen. I really hope nobody wastes
1022 time debugging a case where it can! */
1023 assert (TYPE_PRECISION (ffecom_f2c_ftnlen_type_node
)
1024 >= TYPE_PRECISION (TREE_TYPE (size
)));
1026 size
= convert (ffecom_f2c_ftnlen_type_node
, size
);
1029 if (ffeinfo_rank (ffebld_info (expr
)) == 0
1030 || TREE_CODE (TREE_TYPE (TREE_TYPE (variable
))) != ARRAY_TYPE
)
1031 num_elements
= ffecom_integer_one_node
;
1035 = size_binop (CEIL_DIV_EXPR
,
1036 TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (variable
))),
1037 convert (sizetype
, size
));
1038 num_elements
= size_binop (CEIL_DIV_EXPR
, num_elements
,
1039 size_int (TYPE_PRECISION (char_type_node
)
1041 num_elements
= convert (ffecom_f2c_ftnlen_type_node
,
1046 = ffecom_1 (ADDR_EXPR
, ffecom_f2c_ptr_to_ftnlen_type_node
,
1049 variable
= convert (string_type_node
, variable
);
1051 arglist
= build_tree_list (NULL_TREE
, type_id
);
1052 TREE_CHAIN (arglist
) = build_tree_list (NULL_TREE
, num_elements
);
1053 TREE_CHAIN (TREE_CHAIN (arglist
)) = build_tree_list (NULL_TREE
, variable
);
1054 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (arglist
)))
1055 = build_tree_list (NULL_TREE
, size
);
1057 return ffecom_call_gfrt (FFECOM_gfrtDOLIO
, arglist
, NULL_TREE
);
1060 /* I/O driver for unformatted I/O item (do_uio)
1062 Returns a tree for a CALL_EXPR to the do_uio function, which handles
1063 an unformatted I/O list item, along with the appropriate arguments for
1064 the function. It is up to the caller to set the TREE_SIDE_EFFECTS flag
1065 for the CALL_EXPR, expand (emit) the expression, emit any assignment
1066 of the result to an IOSTAT= variable, and emit any checking of the
1067 result for errors. */
1070 ffeste_io_douio_ (ffebld expr
)
1076 ffeinfoBasictype bt
;
1080 bt
= ffeinfo_basictype (ffebld_info (expr
));
1081 kt
= ffeinfo_kindtype (ffebld_info (expr
));
1083 if ((bt
== FFEINFO_basictypeANY
)
1084 || (kt
== FFEINFO_kindtypeANY
))
1085 return error_mark_node
;
1087 if (bt
== FFEINFO_basictypeCOMPLEX
)
1090 bt
= FFEINFO_basictypeREAL
;
1095 variable
= ffecom_arg_ptr_to_expr (expr
, &size
);
1097 if ((variable
== error_mark_node
)
1098 || (size
== error_mark_node
))
1099 return error_mark_node
;
1101 if (size
== NULL_TREE
) /* Already filled in for CHARACTER type. */
1102 { /* "(ftnlen) sizeof(type)" */
1103 size
= size_binop (CEIL_DIV_EXPR
,
1104 TYPE_SIZE_UNIT (ffecom_tree_type
[bt
][kt
]),
1105 size_int (TYPE_PRECISION (char_type_node
)
1107 #if 0 /* Assume that while it is possible that char * is wider than
1108 ftnlen, no object in Fortran space can get big enough for its
1109 size to be wider than ftnlen. I really hope nobody wastes
1110 time debugging a case where it can! */
1111 assert (TYPE_PRECISION (ffecom_f2c_ftnlen_type_node
)
1112 >= TYPE_PRECISION (TREE_TYPE (size
)));
1114 size
= convert (ffecom_f2c_ftnlen_type_node
, size
);
1117 if (ffeinfo_rank (ffebld_info (expr
)) == 0
1118 || TREE_CODE (TREE_TYPE (TREE_TYPE (variable
))) != ARRAY_TYPE
)
1120 = is_complex
? ffecom_f2c_ftnlen_two_node
: ffecom_f2c_ftnlen_one_node
;
1124 = size_binop (CEIL_DIV_EXPR
,
1125 TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (variable
))),
1126 convert (sizetype
, size
));
1127 num_elements
= size_binop (CEIL_DIV_EXPR
, num_elements
,
1128 size_int (TYPE_PRECISION (char_type_node
)
1130 num_elements
= convert (ffecom_f2c_ftnlen_type_node
,
1135 = ffecom_1 (ADDR_EXPR
, ffecom_f2c_ptr_to_ftnlen_type_node
,
1138 variable
= convert (string_type_node
, variable
);
1140 arglist
= build_tree_list (NULL_TREE
, num_elements
);
1141 TREE_CHAIN (arglist
) = build_tree_list (NULL_TREE
, variable
);
1142 TREE_CHAIN (TREE_CHAIN (arglist
)) = build_tree_list (NULL_TREE
, size
);
1144 return ffecom_call_gfrt (FFECOM_gfrtDOUIO
, arglist
, NULL_TREE
);
1147 /* Make arglist with ptr to BACKSPACE/ENDFILE/REWIND control list.
1149 Returns a tree suitable as an argument list containing a pointer to
1150 a BACKSPACE/ENDFILE/REWIND control list. First, generates that control
1151 list, if necessary, along with any static and run-time initializations
1152 that are needed as specified by the arguments to this function.
1154 Must ensure that all expressions are prepared before being evaluated,
1155 for any whose evaluation might result in the generation of temporaries.
1157 Note that this means this function causes a transition, within the
1158 current block being code-generated via the back end, from the
1159 declaration of variables (temporaries) to the expanding of expressions,
1162 static GTY(()) tree f2c_alist_struct
;
1164 ffeste_io_ialist_ (bool have_err
,
1173 bool constantp
= TRUE
;
1174 static tree errfield
, unitfield
;
1175 tree errinit
, unitinit
;
1177 static int mynumber
= 0;
1179 if (f2c_alist_struct
== NULL_TREE
)
1183 ref
= make_node (RECORD_TYPE
);
1185 errfield
= ffecom_decl_field (ref
, NULL_TREE
, "err",
1186 ffecom_f2c_flag_type_node
);
1187 unitfield
= ffecom_decl_field (ref
, errfield
, "unit",
1188 ffecom_f2c_ftnint_type_node
);
1190 TYPE_FIELDS (ref
) = errfield
;
1193 f2c_alist_struct
= ref
;
1196 /* Try to do as much compile-time initialization of the structure
1197 as possible, to save run time. */
1199 ffeste_f2c_init_flag_ (have_err
, errinit
);
1203 case FFESTV_unitNONE
:
1204 case FFESTV_unitASTERISK
:
1205 unitinit
= build_int_2 (unit_dflt
, 0);
1209 case FFESTV_unitINTEXPR
:
1210 unitexp
= ffecom_const_expr (unit_expr
);
1215 unitinit
= ffecom_integer_zero_node
;
1221 assert ("bad unit spec" == NULL
);
1222 unitinit
= ffecom_integer_zero_node
;
1227 inits
= build_tree_list ((field
= TYPE_FIELDS (f2c_alist_struct
)), errinit
);
1229 ffeste_f2c_init_next_ (unitinit
);
1231 inits
= build_constructor (f2c_alist_struct
, inits
);
1232 TREE_CONSTANT (inits
) = constantp
? 1 : 0;
1233 TREE_STATIC (inits
) = 1;
1235 t
= build_decl (VAR_DECL
,
1236 ffecom_get_invented_identifier ("__g77_alist_%d",
1239 TREE_STATIC (t
) = 1;
1240 t
= ffecom_start_decl (t
, 1);
1241 ffecom_finish_decl (t
, inits
, 0);
1243 /* Prepare run-time expressions. */
1246 ffecom_prepare_expr (unit_expr
);
1248 ffecom_prepare_end ();
1250 /* Now evaluate run-time expressions as needed. */
1254 unitexp
= ffecom_expr (unit_expr
);
1255 ffeste_f2c_compile_ (unitfield
, unitexp
);
1258 ttype
= build_pointer_type (TREE_TYPE (t
));
1259 t
= ffecom_1 (ADDR_EXPR
, ttype
, t
);
1261 t
= build_tree_list (NULL_TREE
, t
);
1266 /* Make arglist with ptr to external-I/O control list.
1268 Returns a tree suitable as an argument list containing a pointer to
1269 an external-I/O control list. First, generates that control
1270 list, if necessary, along with any static and run-time initializations
1271 that are needed as specified by the arguments to this function.
1273 Must ensure that all expressions are prepared before being evaluated,
1274 for any whose evaluation might result in the generation of temporaries.
1276 Note that this means this function causes a transition, within the
1277 current block being code-generated via the back end, from the
1278 declaration of variables (temporaries) to the expanding of expressions,
1281 static GTY(()) tree f2c_cilist_struct
;
1283 ffeste_io_cilist_ (bool have_err
,
1288 ffestvFormat format
,
1289 ffestpFile
*format_spec
,
1297 bool constantp
= TRUE
;
1298 static tree errfield
, unitfield
, endfield
, formatfield
, recfield
;
1299 tree errinit
, unitinit
, endinit
, formatinit
, recinit
;
1300 tree unitexp
, formatexp
, recexp
;
1301 static int mynumber
= 0;
1303 if (f2c_cilist_struct
== NULL_TREE
)
1307 ref
= make_node (RECORD_TYPE
);
1309 errfield
= ffecom_decl_field (ref
, NULL_TREE
, "err",
1310 ffecom_f2c_flag_type_node
);
1311 unitfield
= ffecom_decl_field (ref
, errfield
, "unit",
1312 ffecom_f2c_ftnint_type_node
);
1313 endfield
= ffecom_decl_field (ref
, unitfield
, "end",
1314 ffecom_f2c_flag_type_node
);
1315 formatfield
= ffecom_decl_field (ref
, endfield
, "format",
1317 recfield
= ffecom_decl_field (ref
, formatfield
, "rec",
1318 ffecom_f2c_ftnint_type_node
);
1320 TYPE_FIELDS (ref
) = errfield
;
1323 f2c_cilist_struct
= ref
;
1326 /* Try to do as much compile-time initialization of the structure
1327 as possible, to save run time. */
1329 ffeste_f2c_init_flag_ (have_err
, errinit
);
1333 case FFESTV_unitNONE
:
1334 case FFESTV_unitASTERISK
:
1335 unitinit
= build_int_2 (unit_dflt
, 0);
1339 case FFESTV_unitINTEXPR
:
1340 unitexp
= ffecom_const_expr (unit_expr
);
1345 unitinit
= ffecom_integer_zero_node
;
1351 assert ("bad unit spec" == NULL
);
1352 unitinit
= ffecom_integer_zero_node
;
1359 case FFESTV_formatNONE
:
1360 formatinit
= null_pointer_node
;
1361 formatexp
= formatinit
;
1364 case FFESTV_formatLABEL
:
1365 formatexp
= error_mark_node
;
1366 formatinit
= ffecom_lookup_label (format_spec
->u
.label
);
1367 if ((formatinit
== NULL_TREE
)
1368 || (TREE_CODE (formatinit
) == ERROR_MARK
))
1370 formatinit
= ffecom_1 (ADDR_EXPR
,
1371 build_pointer_type (void_type_node
),
1373 TREE_CONSTANT (formatinit
) = 1;
1376 case FFESTV_formatCHAREXPR
:
1377 formatexp
= ffecom_arg_ptr_to_const_expr (format_spec
->u
.expr
, NULL
);
1379 formatinit
= formatexp
;
1382 formatinit
= null_pointer_node
;
1387 case FFESTV_formatASTERISK
:
1388 formatinit
= null_pointer_node
;
1389 formatexp
= formatinit
;
1392 case FFESTV_formatINTEXPR
:
1393 formatinit
= null_pointer_node
;
1394 formatexp
= ffecom_expr_assign (format_spec
->u
.expr
);
1395 if (GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (formatexp
)))
1396 < GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node
))))
1397 error ("ASSIGNed FORMAT specifier is too small");
1398 formatexp
= convert (string_type_node
, formatexp
);
1401 case FFESTV_formatNAMELIST
:
1402 formatinit
= ffecom_expr (format_spec
->u
.expr
);
1403 formatexp
= formatinit
;
1407 assert ("bad format spec" == NULL
);
1408 formatinit
= integer_zero_node
;
1409 formatexp
= formatinit
;
1413 ffeste_f2c_init_flag_ (have_end
, endinit
);
1416 recexp
= ffecom_const_expr (rec_expr
);
1418 recexp
= ffecom_integer_zero_node
;
1423 recinit
= ffecom_integer_zero_node
;
1427 inits
= build_tree_list ((field
= TYPE_FIELDS (f2c_cilist_struct
)), errinit
);
1429 ffeste_f2c_init_next_ (unitinit
);
1430 ffeste_f2c_init_next_ (endinit
);
1431 ffeste_f2c_init_next_ (formatinit
);
1432 ffeste_f2c_init_next_ (recinit
);
1434 inits
= build_constructor (f2c_cilist_struct
, inits
);
1435 TREE_CONSTANT (inits
) = constantp
? 1 : 0;
1436 TREE_STATIC (inits
) = 1;
1438 t
= build_decl (VAR_DECL
,
1439 ffecom_get_invented_identifier ("__g77_cilist_%d",
1442 TREE_STATIC (t
) = 1;
1443 t
= ffecom_start_decl (t
, 1);
1444 ffecom_finish_decl (t
, inits
, 0);
1446 /* Prepare run-time expressions. */
1449 ffecom_prepare_expr (unit_expr
);
1452 ffecom_prepare_arg_ptr_to_expr (format_spec
->u
.expr
);
1455 ffecom_prepare_expr (rec_expr
);
1457 ffecom_prepare_end ();
1459 /* Now evaluate run-time expressions as needed. */
1463 unitexp
= ffecom_expr (unit_expr
);
1464 ffeste_f2c_compile_ (unitfield
, unitexp
);
1469 formatexp
= ffecom_arg_ptr_to_expr (format_spec
->u
.expr
, NULL
);
1470 ffeste_f2c_compile_ (formatfield
, formatexp
);
1472 else if (format
== FFESTV_formatINTEXPR
)
1473 ffeste_f2c_compile_ (formatfield
, formatexp
);
1477 recexp
= ffecom_expr (rec_expr
);
1478 ffeste_f2c_compile_ (recfield
, recexp
);
1481 ttype
= build_pointer_type (TREE_TYPE (t
));
1482 t
= ffecom_1 (ADDR_EXPR
, ttype
, t
);
1484 t
= build_tree_list (NULL_TREE
, t
);
1489 /* Make arglist with ptr to CLOSE control list.
1491 Returns a tree suitable as an argument list containing a pointer to
1492 a CLOSE-statement control list. First, generates that control
1493 list, if necessary, along with any static and run-time initializations
1494 that are needed as specified by the arguments to this function.
1496 Must ensure that all expressions are prepared before being evaluated,
1497 for any whose evaluation might result in the generation of temporaries.
1499 Note that this means this function causes a transition, within the
1500 current block being code-generated via the back end, from the
1501 declaration of variables (temporaries) to the expanding of expressions,
1504 static GTY(()) tree f2c_close_struct
;
1506 ffeste_io_cllist_ (bool have_err
,
1508 ffestpFile
*stat_spec
)
1514 tree ignore
; /* Ignore length info for certain fields. */
1515 bool constantp
= TRUE
;
1516 static tree errfield
, unitfield
, statfield
;
1517 tree errinit
, unitinit
, statinit
;
1518 tree unitexp
, statexp
;
1519 static int mynumber
= 0;
1521 if (f2c_close_struct
== NULL_TREE
)
1525 ref
= make_node (RECORD_TYPE
);
1527 errfield
= ffecom_decl_field (ref
, NULL_TREE
, "err",
1528 ffecom_f2c_flag_type_node
);
1529 unitfield
= ffecom_decl_field (ref
, errfield
, "unit",
1530 ffecom_f2c_ftnint_type_node
);
1531 statfield
= ffecom_decl_field (ref
, unitfield
, "stat",
1534 TYPE_FIELDS (ref
) = errfield
;
1537 f2c_close_struct
= ref
;
1540 /* Try to do as much compile-time initialization of the structure
1541 as possible, to save run time. */
1543 ffeste_f2c_init_flag_ (have_err
, errinit
);
1545 unitexp
= ffecom_const_expr (unit_expr
);
1550 unitinit
= ffecom_integer_zero_node
;
1554 ffeste_f2c_init_charnolen_ (statexp
, statinit
, stat_spec
);
1556 inits
= build_tree_list ((field
= TYPE_FIELDS (f2c_close_struct
)), errinit
);
1558 ffeste_f2c_init_next_ (unitinit
);
1559 ffeste_f2c_init_next_ (statinit
);
1561 inits
= build_constructor (f2c_close_struct
, inits
);
1562 TREE_CONSTANT (inits
) = constantp
? 1 : 0;
1563 TREE_STATIC (inits
) = 1;
1565 t
= build_decl (VAR_DECL
,
1566 ffecom_get_invented_identifier ("__g77_cllist_%d",
1569 TREE_STATIC (t
) = 1;
1570 t
= ffecom_start_decl (t
, 1);
1571 ffecom_finish_decl (t
, inits
, 0);
1573 /* Prepare run-time expressions. */
1576 ffecom_prepare_expr (unit_expr
);
1579 ffecom_prepare_arg_ptr_to_expr (stat_spec
->u
.expr
);
1581 ffecom_prepare_end ();
1583 /* Now evaluate run-time expressions as needed. */
1587 unitexp
= ffecom_expr (unit_expr
);
1588 ffeste_f2c_compile_ (unitfield
, unitexp
);
1591 ffeste_f2c_compile_charnolen_ (statfield
, stat_spec
, statexp
);
1593 ttype
= build_pointer_type (TREE_TYPE (t
));
1594 t
= ffecom_1 (ADDR_EXPR
, ttype
, t
);
1596 t
= build_tree_list (NULL_TREE
, t
);
1601 /* Make arglist with ptr to internal-I/O control list.
1603 Returns a tree suitable as an argument list containing a pointer to
1604 an internal-I/O control list. First, generates that control
1605 list, if necessary, along with any static and run-time initializations
1606 that are needed as specified by the arguments to this function.
1608 Must ensure that all expressions are prepared before being evaluated,
1609 for any whose evaluation might result in the generation of temporaries.
1611 Note that this means this function causes a transition, within the
1612 current block being code-generated via the back end, from the
1613 declaration of variables (temporaries) to the expanding of expressions,
1616 static GTY(()) tree f2c_icilist_struct
;
1618 ffeste_io_icilist_ (bool have_err
,
1621 ffestvFormat format
,
1622 ffestpFile
*format_spec
)
1628 bool constantp
= TRUE
;
1629 static tree errfield
, unitfield
, endfield
, formatfield
, unitlenfield
,
1631 tree errinit
, unitinit
, endinit
, formatinit
, unitleninit
, unitnuminit
;
1632 tree unitexp
, formatexp
, unitlenexp
, unitnumexp
;
1633 static int mynumber
= 0;
1635 if (f2c_icilist_struct
== NULL_TREE
)
1639 ref
= make_node (RECORD_TYPE
);
1641 errfield
= ffecom_decl_field (ref
, NULL_TREE
, "err",
1642 ffecom_f2c_flag_type_node
);
1643 unitfield
= ffecom_decl_field (ref
, errfield
, "unit",
1645 endfield
= ffecom_decl_field (ref
, unitfield
, "end",
1646 ffecom_f2c_flag_type_node
);
1647 formatfield
= ffecom_decl_field (ref
, endfield
, "format",
1649 unitlenfield
= ffecom_decl_field (ref
, formatfield
, "unitlen",
1650 ffecom_f2c_ftnint_type_node
);
1651 unitnumfield
= ffecom_decl_field (ref
, unitlenfield
, "unitnum",
1652 ffecom_f2c_ftnint_type_node
);
1654 TYPE_FIELDS (ref
) = errfield
;
1657 f2c_icilist_struct
= ref
;
1660 /* Try to do as much compile-time initialization of the structure
1661 as possible, to save run time. */
1663 ffeste_f2c_init_flag_ (have_err
, errinit
);
1665 unitexp
= ffecom_arg_ptr_to_const_expr (unit_expr
, &unitlenexp
);
1670 unitinit
= null_pointer_node
;
1674 unitleninit
= unitlenexp
;
1677 unitleninit
= ffecom_integer_zero_node
;
1681 /* Now see if we can fully initialize the number of elements, or
1682 if we have to compute that at run time. */
1683 if (ffeinfo_rank (ffebld_info (unit_expr
)) == 0
1685 && TREE_CODE (TREE_TYPE (TREE_TYPE (unitexp
))) != ARRAY_TYPE
))
1687 /* Not an array, so just one element. */
1688 unitnuminit
= ffecom_integer_one_node
;
1689 unitnumexp
= unitnuminit
;
1691 else if (unitexp
&& unitlenexp
)
1693 /* An array, but all the info is constant, so compute now. */
1695 = size_binop (CEIL_DIV_EXPR
,
1696 TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (unitexp
))),
1697 convert (sizetype
, unitlenexp
));
1698 unitnuminit
= size_binop (CEIL_DIV_EXPR
, unitnuminit
,
1699 size_int (TYPE_PRECISION (char_type_node
)
1701 unitnumexp
= unitnuminit
;
1705 /* Put off computing until run time. */
1706 unitnuminit
= ffecom_integer_zero_node
;
1707 unitnumexp
= NULL_TREE
;
1713 case FFESTV_formatNONE
:
1714 formatinit
= null_pointer_node
;
1715 formatexp
= formatinit
;
1718 case FFESTV_formatLABEL
:
1719 formatexp
= error_mark_node
;
1720 formatinit
= ffecom_lookup_label (format_spec
->u
.label
);
1721 if ((formatinit
== NULL_TREE
)
1722 || (TREE_CODE (formatinit
) == ERROR_MARK
))
1724 formatinit
= ffecom_1 (ADDR_EXPR
,
1725 build_pointer_type (void_type_node
),
1727 TREE_CONSTANT (formatinit
) = 1;
1730 case FFESTV_formatCHAREXPR
:
1731 ffeste_f2c_init_format_ (formatexp
, formatinit
, format_spec
);
1734 case FFESTV_formatASTERISK
:
1735 formatinit
= null_pointer_node
;
1736 formatexp
= formatinit
;
1739 case FFESTV_formatINTEXPR
:
1740 formatinit
= null_pointer_node
;
1741 formatexp
= ffecom_expr_assign (format_spec
->u
.expr
);
1742 if (GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (formatexp
)))
1743 < GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node
))))
1744 error ("ASSIGNed FORMAT specifier is too small");
1745 formatexp
= convert (string_type_node
, formatexp
);
1749 assert ("bad format spec" == NULL
);
1750 formatinit
= ffecom_integer_zero_node
;
1751 formatexp
= formatinit
;
1755 ffeste_f2c_init_flag_ (have_end
, endinit
);
1757 inits
= build_tree_list ((field
= TYPE_FIELDS (f2c_icilist_struct
)),
1760 ffeste_f2c_init_next_ (unitinit
);
1761 ffeste_f2c_init_next_ (endinit
);
1762 ffeste_f2c_init_next_ (formatinit
);
1763 ffeste_f2c_init_next_ (unitleninit
);
1764 ffeste_f2c_init_next_ (unitnuminit
);
1766 inits
= build_constructor (f2c_icilist_struct
, inits
);
1767 TREE_CONSTANT (inits
) = constantp
? 1 : 0;
1768 TREE_STATIC (inits
) = 1;
1770 t
= build_decl (VAR_DECL
,
1771 ffecom_get_invented_identifier ("__g77_icilist_%d",
1773 f2c_icilist_struct
);
1774 TREE_STATIC (t
) = 1;
1775 t
= ffecom_start_decl (t
, 1);
1776 ffecom_finish_decl (t
, inits
, 0);
1778 /* Prepare run-time expressions. */
1781 ffecom_prepare_arg_ptr_to_expr (unit_expr
);
1783 ffeste_f2c_prepare_format_ (format_spec
, formatexp
);
1785 ffecom_prepare_end ();
1787 /* Now evaluate run-time expressions as needed. */
1789 if (! unitexp
|| ! unitlenexp
)
1791 int need_unitexp
= (! unitexp
);
1792 int need_unitlenexp
= (! unitlenexp
);
1794 unitexp
= ffecom_arg_ptr_to_expr (unit_expr
, &unitlenexp
);
1796 ffeste_f2c_compile_ (unitfield
, unitexp
);
1797 if (need_unitlenexp
)
1798 ffeste_f2c_compile_ (unitlenfield
, unitlenexp
);
1802 && unitexp
!= error_mark_node
1803 && unitlenexp
!= error_mark_node
)
1806 = size_binop (CEIL_DIV_EXPR
,
1807 TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (unitexp
))),
1808 convert (sizetype
, unitlenexp
));
1809 unitnumexp
= size_binop (CEIL_DIV_EXPR
, unitnumexp
,
1810 size_int (TYPE_PRECISION (char_type_node
)
1812 ffeste_f2c_compile_ (unitnumfield
, unitnumexp
);
1815 if (format
== FFESTV_formatINTEXPR
)
1816 ffeste_f2c_compile_ (formatfield
, formatexp
);
1818 ffeste_f2c_compile_format_ (formatfield
, format_spec
, formatexp
);
1820 ttype
= build_pointer_type (TREE_TYPE (t
));
1821 t
= ffecom_1 (ADDR_EXPR
, ttype
, t
);
1823 t
= build_tree_list (NULL_TREE
, t
);
1828 /* Make arglist with ptr to INQUIRE control list
1830 Returns a tree suitable as an argument list containing a pointer to
1831 an INQUIRE-statement control list. First, generates that control
1832 list, if necessary, along with any static and run-time initializations
1833 that are needed as specified by the arguments to this function.
1835 Must ensure that all expressions are prepared before being evaluated,
1836 for any whose evaluation might result in the generation of temporaries.
1838 Note that this means this function causes a transition, within the
1839 current block being code-generated via the back end, from the
1840 declaration of variables (temporaries) to the expanding of expressions,
1843 static GTY(()) tree f2c_inquire_struct
;
1845 ffeste_io_inlist_ (bool have_err
,
1846 ffestpFile
*unit_spec
,
1847 ffestpFile
*file_spec
,
1848 ffestpFile
*exist_spec
,
1849 ffestpFile
*open_spec
,
1850 ffestpFile
*number_spec
,
1851 ffestpFile
*named_spec
,
1852 ffestpFile
*name_spec
,
1853 ffestpFile
*access_spec
,
1854 ffestpFile
*sequential_spec
,
1855 ffestpFile
*direct_spec
,
1856 ffestpFile
*form_spec
,
1857 ffestpFile
*formatted_spec
,
1858 ffestpFile
*unformatted_spec
,
1859 ffestpFile
*recl_spec
,
1860 ffestpFile
*nextrec_spec
,
1861 ffestpFile
*blank_spec
)
1867 bool constantp
= TRUE
;
1868 static tree errfield
, unitfield
, filefield
, filelenfield
, existfield
,
1869 openfield
, numberfield
, namedfield
, namefield
, namelenfield
, accessfield
,
1870 accesslenfield
, sequentialfield
, sequentiallenfield
, directfield
, directlenfield
,
1871 formfield
, formlenfield
, formattedfield
, formattedlenfield
, unformattedfield
,
1872 unformattedlenfield
, reclfield
, nextrecfield
, blankfield
, blanklenfield
;
1873 tree errinit
, unitinit
, fileinit
, fileleninit
, existinit
, openinit
, numberinit
,
1874 namedinit
, nameinit
, nameleninit
, accessinit
, accessleninit
, sequentialinit
,
1875 sequentialleninit
, directinit
, directleninit
, forminit
, formleninit
,
1876 formattedinit
, formattedleninit
, unformattedinit
, unformattedleninit
,
1877 reclinit
, nextrecinit
, blankinit
, blankleninit
;
1879 unitexp
, fileexp
, filelenexp
, existexp
, openexp
, numberexp
, namedexp
,
1880 nameexp
, namelenexp
, accessexp
, accesslenexp
, sequentialexp
, sequentiallenexp
,
1881 directexp
, directlenexp
, formexp
, formlenexp
, formattedexp
, formattedlenexp
,
1882 unformattedexp
, unformattedlenexp
, reclexp
, nextrecexp
, blankexp
, blanklenexp
;
1883 static int mynumber
= 0;
1885 if (f2c_inquire_struct
== NULL_TREE
)
1889 ref
= make_node (RECORD_TYPE
);
1891 errfield
= ffecom_decl_field (ref
, NULL_TREE
, "err",
1892 ffecom_f2c_flag_type_node
);
1893 unitfield
= ffecom_decl_field (ref
, errfield
, "unit",
1894 ffecom_f2c_ftnint_type_node
);
1895 filefield
= ffecom_decl_field (ref
, unitfield
, "file",
1897 filelenfield
= ffecom_decl_field (ref
, filefield
, "filelen",
1898 ffecom_f2c_ftnlen_type_node
);
1899 existfield
= ffecom_decl_field (ref
, filelenfield
, "exist",
1900 ffecom_f2c_ptr_to_ftnint_type_node
);
1901 openfield
= ffecom_decl_field (ref
, existfield
, "open",
1902 ffecom_f2c_ptr_to_ftnint_type_node
);
1903 numberfield
= ffecom_decl_field (ref
, openfield
, "number",
1904 ffecom_f2c_ptr_to_ftnint_type_node
);
1905 namedfield
= ffecom_decl_field (ref
, numberfield
, "named",
1906 ffecom_f2c_ptr_to_ftnint_type_node
);
1907 namefield
= ffecom_decl_field (ref
, namedfield
, "name",
1909 namelenfield
= ffecom_decl_field (ref
, namefield
, "namelen",
1910 ffecom_f2c_ftnlen_type_node
);
1911 accessfield
= ffecom_decl_field (ref
, namelenfield
, "access",
1913 accesslenfield
= ffecom_decl_field (ref
, accessfield
, "accesslen",
1914 ffecom_f2c_ftnlen_type_node
);
1915 sequentialfield
= ffecom_decl_field (ref
, accesslenfield
, "sequential",
1917 sequentiallenfield
= ffecom_decl_field (ref
, sequentialfield
,
1919 ffecom_f2c_ftnlen_type_node
);
1920 directfield
= ffecom_decl_field (ref
, sequentiallenfield
, "direct",
1922 directlenfield
= ffecom_decl_field (ref
, directfield
, "directlen",
1923 ffecom_f2c_ftnlen_type_node
);
1924 formfield
= ffecom_decl_field (ref
, directlenfield
, "form",
1926 formlenfield
= ffecom_decl_field (ref
, formfield
, "formlen",
1927 ffecom_f2c_ftnlen_type_node
);
1928 formattedfield
= ffecom_decl_field (ref
, formlenfield
, "formatted",
1930 formattedlenfield
= ffecom_decl_field (ref
, formattedfield
,
1932 ffecom_f2c_ftnlen_type_node
);
1933 unformattedfield
= ffecom_decl_field (ref
, formattedlenfield
,
1936 unformattedlenfield
= ffecom_decl_field (ref
, unformattedfield
,
1938 ffecom_f2c_ftnlen_type_node
);
1939 reclfield
= ffecom_decl_field (ref
, unformattedlenfield
, "recl",
1940 ffecom_f2c_ptr_to_ftnint_type_node
);
1941 nextrecfield
= ffecom_decl_field (ref
, reclfield
, "nextrec",
1942 ffecom_f2c_ptr_to_ftnint_type_node
);
1943 blankfield
= ffecom_decl_field (ref
, nextrecfield
, "blank",
1945 blanklenfield
= ffecom_decl_field (ref
, blankfield
, "blanklen",
1946 ffecom_f2c_ftnlen_type_node
);
1948 TYPE_FIELDS (ref
) = errfield
;
1951 f2c_inquire_struct
= ref
;
1954 /* Try to do as much compile-time initialization of the structure
1955 as possible, to save run time. */
1957 ffeste_f2c_init_flag_ (have_err
, errinit
);
1958 ffeste_f2c_init_int_ (unitexp
, unitinit
, unit_spec
);
1959 ffeste_f2c_init_char_ (fileexp
, fileinit
, filelenexp
, fileleninit
,
1961 ffeste_f2c_init_ptrtoint_ (existexp
, existinit
, exist_spec
);
1962 ffeste_f2c_init_ptrtoint_ (openexp
, openinit
, open_spec
);
1963 ffeste_f2c_init_ptrtoint_ (numberexp
, numberinit
, number_spec
);
1964 ffeste_f2c_init_ptrtoint_ (namedexp
, namedinit
, named_spec
);
1965 ffeste_f2c_init_char_ (nameexp
, nameinit
, namelenexp
, nameleninit
,
1967 ffeste_f2c_init_char_ (accessexp
, accessinit
, accesslenexp
,
1968 accessleninit
, access_spec
);
1969 ffeste_f2c_init_char_ (sequentialexp
, sequentialinit
, sequentiallenexp
,
1970 sequentialleninit
, sequential_spec
);
1971 ffeste_f2c_init_char_ (directexp
, directinit
, directlenexp
,
1972 directleninit
, direct_spec
);
1973 ffeste_f2c_init_char_ (formexp
, forminit
, formlenexp
, formleninit
,
1975 ffeste_f2c_init_char_ (formattedexp
, formattedinit
,
1976 formattedlenexp
, formattedleninit
, formatted_spec
);
1977 ffeste_f2c_init_char_ (unformattedexp
, unformattedinit
, unformattedlenexp
,
1978 unformattedleninit
, unformatted_spec
);
1979 ffeste_f2c_init_ptrtoint_ (reclexp
, reclinit
, recl_spec
);
1980 ffeste_f2c_init_ptrtoint_ (nextrecexp
, nextrecinit
, nextrec_spec
);
1981 ffeste_f2c_init_char_ (blankexp
, blankinit
, blanklenexp
,
1982 blankleninit
, blank_spec
);
1984 inits
= build_tree_list ((field
= TYPE_FIELDS (f2c_inquire_struct
)),
1987 ffeste_f2c_init_next_ (unitinit
);
1988 ffeste_f2c_init_next_ (fileinit
);
1989 ffeste_f2c_init_next_ (fileleninit
);
1990 ffeste_f2c_init_next_ (existinit
);
1991 ffeste_f2c_init_next_ (openinit
);
1992 ffeste_f2c_init_next_ (numberinit
);
1993 ffeste_f2c_init_next_ (namedinit
);
1994 ffeste_f2c_init_next_ (nameinit
);
1995 ffeste_f2c_init_next_ (nameleninit
);
1996 ffeste_f2c_init_next_ (accessinit
);
1997 ffeste_f2c_init_next_ (accessleninit
);
1998 ffeste_f2c_init_next_ (sequentialinit
);
1999 ffeste_f2c_init_next_ (sequentialleninit
);
2000 ffeste_f2c_init_next_ (directinit
);
2001 ffeste_f2c_init_next_ (directleninit
);
2002 ffeste_f2c_init_next_ (forminit
);
2003 ffeste_f2c_init_next_ (formleninit
);
2004 ffeste_f2c_init_next_ (formattedinit
);
2005 ffeste_f2c_init_next_ (formattedleninit
);
2006 ffeste_f2c_init_next_ (unformattedinit
);
2007 ffeste_f2c_init_next_ (unformattedleninit
);
2008 ffeste_f2c_init_next_ (reclinit
);
2009 ffeste_f2c_init_next_ (nextrecinit
);
2010 ffeste_f2c_init_next_ (blankinit
);
2011 ffeste_f2c_init_next_ (blankleninit
);
2013 inits
= build_constructor (f2c_inquire_struct
, inits
);
2014 TREE_CONSTANT (inits
) = constantp
? 1 : 0;
2015 TREE_STATIC (inits
) = 1;
2017 t
= build_decl (VAR_DECL
,
2018 ffecom_get_invented_identifier ("__g77_inlist_%d",
2020 f2c_inquire_struct
);
2021 TREE_STATIC (t
) = 1;
2022 t
= ffecom_start_decl (t
, 1);
2023 ffecom_finish_decl (t
, inits
, 0);
2025 /* Prepare run-time expressions. */
2027 ffeste_f2c_prepare_int_ (unit_spec
, unitexp
);
2028 ffeste_f2c_prepare_char_ (file_spec
, fileexp
);
2029 ffeste_f2c_prepare_ptrtoint_ (exist_spec
, existexp
);
2030 ffeste_f2c_prepare_ptrtoint_ (open_spec
, openexp
);
2031 ffeste_f2c_prepare_ptrtoint_ (number_spec
, numberexp
);
2032 ffeste_f2c_prepare_ptrtoint_ (named_spec
, namedexp
);
2033 ffeste_f2c_prepare_char_ (name_spec
, nameexp
);
2034 ffeste_f2c_prepare_char_ (access_spec
, accessexp
);
2035 ffeste_f2c_prepare_char_ (sequential_spec
, sequentialexp
);
2036 ffeste_f2c_prepare_char_ (direct_spec
, directexp
);
2037 ffeste_f2c_prepare_char_ (form_spec
, formexp
);
2038 ffeste_f2c_prepare_char_ (formatted_spec
, formattedexp
);
2039 ffeste_f2c_prepare_char_ (unformatted_spec
, unformattedexp
);
2040 ffeste_f2c_prepare_ptrtoint_ (recl_spec
, reclexp
);
2041 ffeste_f2c_prepare_ptrtoint_ (nextrec_spec
, nextrecexp
);
2042 ffeste_f2c_prepare_char_ (blank_spec
, blankexp
);
2044 ffecom_prepare_end ();
2046 /* Now evaluate run-time expressions as needed. */
2048 ffeste_f2c_compile_int_ (unitfield
, unit_spec
, unitexp
);
2049 ffeste_f2c_compile_char_ (filefield
, filelenfield
, file_spec
,
2050 fileexp
, filelenexp
);
2051 ffeste_f2c_compile_ptrtoint_ (existfield
, exist_spec
, existexp
);
2052 ffeste_f2c_compile_ptrtoint_ (openfield
, open_spec
, openexp
);
2053 ffeste_f2c_compile_ptrtoint_ (numberfield
, number_spec
, numberexp
);
2054 ffeste_f2c_compile_ptrtoint_ (namedfield
, named_spec
, namedexp
);
2055 ffeste_f2c_compile_char_ (namefield
, namelenfield
, name_spec
, nameexp
,
2057 ffeste_f2c_compile_char_ (accessfield
, accesslenfield
, access_spec
,
2058 accessexp
, accesslenexp
);
2059 ffeste_f2c_compile_char_ (sequentialfield
, sequentiallenfield
,
2060 sequential_spec
, sequentialexp
,
2062 ffeste_f2c_compile_char_ (directfield
, directlenfield
, direct_spec
,
2063 directexp
, directlenexp
);
2064 ffeste_f2c_compile_char_ (formfield
, formlenfield
, form_spec
, formexp
,
2066 ffeste_f2c_compile_char_ (formattedfield
, formattedlenfield
, formatted_spec
,
2067 formattedexp
, formattedlenexp
);
2068 ffeste_f2c_compile_char_ (unformattedfield
, unformattedlenfield
,
2069 unformatted_spec
, unformattedexp
,
2071 ffeste_f2c_compile_ptrtoint_ (reclfield
, recl_spec
, reclexp
);
2072 ffeste_f2c_compile_ptrtoint_ (nextrecfield
, nextrec_spec
, nextrecexp
);
2073 ffeste_f2c_compile_char_ (blankfield
, blanklenfield
, blank_spec
, blankexp
,
2076 ttype
= build_pointer_type (TREE_TYPE (t
));
2077 t
= ffecom_1 (ADDR_EXPR
, ttype
, t
);
2079 t
= build_tree_list (NULL_TREE
, t
);
2084 /* Make arglist with ptr to OPEN control list
2086 Returns a tree suitable as an argument list containing a pointer to
2087 an OPEN-statement control list. First, generates that control
2088 list, if necessary, along with any static and run-time initializations
2089 that are needed as specified by the arguments to this function.
2091 Must ensure that all expressions are prepared before being evaluated,
2092 for any whose evaluation might result in the generation of temporaries.
2094 Note that this means this function causes a transition, within the
2095 current block being code-generated via the back end, from the
2096 declaration of variables (temporaries) to the expanding of expressions,
2099 static GTY(()) tree f2c_open_struct
;
2101 ffeste_io_olist_ (bool have_err
,
2103 ffestpFile
*file_spec
,
2104 ffestpFile
*stat_spec
,
2105 ffestpFile
*access_spec
,
2106 ffestpFile
*form_spec
,
2107 ffestpFile
*recl_spec
,
2108 ffestpFile
*blank_spec
)
2114 tree ignore
; /* Ignore length info for certain fields. */
2115 bool constantp
= TRUE
;
2116 static tree errfield
, unitfield
, filefield
, filelenfield
, statfield
,
2117 accessfield
, formfield
, reclfield
, blankfield
;
2118 tree errinit
, unitinit
, fileinit
, fileleninit
, statinit
, accessinit
,
2119 forminit
, reclinit
, blankinit
;
2121 unitexp
, fileexp
, filelenexp
, statexp
, accessexp
, formexp
, reclexp
,
2123 static int mynumber
= 0;
2125 if (f2c_open_struct
== NULL_TREE
)
2129 ref
= make_node (RECORD_TYPE
);
2131 errfield
= ffecom_decl_field (ref
, NULL_TREE
, "err",
2132 ffecom_f2c_flag_type_node
);
2133 unitfield
= ffecom_decl_field (ref
, errfield
, "unit",
2134 ffecom_f2c_ftnint_type_node
);
2135 filefield
= ffecom_decl_field (ref
, unitfield
, "file",
2137 filelenfield
= ffecom_decl_field (ref
, filefield
, "filelen",
2138 ffecom_f2c_ftnlen_type_node
);
2139 statfield
= ffecom_decl_field (ref
, filelenfield
, "stat",
2141 accessfield
= ffecom_decl_field (ref
, statfield
, "access",
2143 formfield
= ffecom_decl_field (ref
, accessfield
, "form",
2145 reclfield
= ffecom_decl_field (ref
, formfield
, "recl",
2146 ffecom_f2c_ftnint_type_node
);
2147 blankfield
= ffecom_decl_field (ref
, reclfield
, "blank",
2150 TYPE_FIELDS (ref
) = errfield
;
2153 f2c_open_struct
= ref
;
2156 /* Try to do as much compile-time initialization of the structure
2157 as possible, to save run time. */
2159 ffeste_f2c_init_flag_ (have_err
, errinit
);
2161 unitexp
= ffecom_const_expr (unit_expr
);
2166 unitinit
= ffecom_integer_zero_node
;
2170 ffeste_f2c_init_char_ (fileexp
, fileinit
, filelenexp
, fileleninit
,
2172 ffeste_f2c_init_charnolen_ (statexp
, statinit
, stat_spec
);
2173 ffeste_f2c_init_charnolen_ (accessexp
, accessinit
, access_spec
);
2174 ffeste_f2c_init_charnolen_ (formexp
, forminit
, form_spec
);
2175 ffeste_f2c_init_int_ (reclexp
, reclinit
, recl_spec
);
2176 ffeste_f2c_init_charnolen_ (blankexp
, blankinit
, blank_spec
);
2178 inits
= build_tree_list ((field
= TYPE_FIELDS (f2c_open_struct
)), errinit
);
2180 ffeste_f2c_init_next_ (unitinit
);
2181 ffeste_f2c_init_next_ (fileinit
);
2182 ffeste_f2c_init_next_ (fileleninit
);
2183 ffeste_f2c_init_next_ (statinit
);
2184 ffeste_f2c_init_next_ (accessinit
);
2185 ffeste_f2c_init_next_ (forminit
);
2186 ffeste_f2c_init_next_ (reclinit
);
2187 ffeste_f2c_init_next_ (blankinit
);
2189 inits
= build_constructor (f2c_open_struct
, inits
);
2190 TREE_CONSTANT (inits
) = constantp
? 1 : 0;
2191 TREE_STATIC (inits
) = 1;
2193 t
= build_decl (VAR_DECL
,
2194 ffecom_get_invented_identifier ("__g77_olist_%d",
2197 TREE_STATIC (t
) = 1;
2198 t
= ffecom_start_decl (t
, 1);
2199 ffecom_finish_decl (t
, inits
, 0);
2201 /* Prepare run-time expressions. */
2204 ffecom_prepare_expr (unit_expr
);
2206 ffeste_f2c_prepare_char_ (file_spec
, fileexp
);
2207 ffeste_f2c_prepare_charnolen_ (stat_spec
, statexp
);
2208 ffeste_f2c_prepare_charnolen_ (access_spec
, accessexp
);
2209 ffeste_f2c_prepare_charnolen_ (form_spec
, formexp
);
2210 ffeste_f2c_prepare_int_ (recl_spec
, reclexp
);
2211 ffeste_f2c_prepare_charnolen_ (blank_spec
, blankexp
);
2213 ffecom_prepare_end ();
2215 /* Now evaluate run-time expressions as needed. */
2219 unitexp
= ffecom_expr (unit_expr
);
2220 ffeste_f2c_compile_ (unitfield
, unitexp
);
2223 ffeste_f2c_compile_char_ (filefield
, filelenfield
, file_spec
, fileexp
,
2225 ffeste_f2c_compile_charnolen_ (statfield
, stat_spec
, statexp
);
2226 ffeste_f2c_compile_charnolen_ (accessfield
, access_spec
, accessexp
);
2227 ffeste_f2c_compile_charnolen_ (formfield
, form_spec
, formexp
);
2228 ffeste_f2c_compile_int_ (reclfield
, recl_spec
, reclexp
);
2229 ffeste_f2c_compile_charnolen_ (blankfield
, blank_spec
, blankexp
);
2231 ttype
= build_pointer_type (TREE_TYPE (t
));
2232 t
= ffecom_1 (ADDR_EXPR
, ttype
, t
);
2234 t
= build_tree_list (NULL_TREE
, t
);
2239 /* Generate code for BACKSPACE/ENDFILE/REWIND. */
2242 ffeste_subr_beru_ (ffestpBeruStmt
*info
, ffecomGfrt rt
)
2248 ffeste_emit_line_note_ ();
2250 #define specified(something) (info->beru_spec[something].kw_or_val_present)
2252 iostat
= specified (FFESTP_beruixIOSTAT
);
2253 errl
= specified (FFESTP_beruixERR
);
2257 /* ~~For now, we assume the unit number is specified and is not ASTERISK,
2258 because the FFE doesn't support BACKSPACE(*) and rejects a BACKSPACE
2259 without any unit specifier. f2c, however, supports the former
2260 construct. When it is time to add this feature to the FFE, which
2261 probably is fairly easy, ffestc_R919 and company will want to pass an
2262 ffestvUnit indicator of FFESTV_unitINTEXPR or _unitASTERISK to
2263 ffeste_R919 and company, and they will want to pass that same value to
2264 this function, and that argument will replace the constant _unitINTEXPR_
2265 in the call below. Right now, the default unit number, 6, is ignored. */
2267 ffeste_start_stmt_ ();
2271 /* Have ERR= specification. */
2275 = ffecom_lookup_label
2276 (info
->beru_spec
[FFESTP_beruixERR
].u
.label
);
2277 ffeste_io_abort_is_temp_
= FALSE
;
2281 /* No ERR= specification. */
2283 ffeste_io_err_
= NULL_TREE
;
2285 if ((ffeste_io_abort_is_temp_
= iostat
))
2286 ffeste_io_abort_
= ffecom_temp_label ();
2288 ffeste_io_abort_
= NULL_TREE
;
2293 /* Have IOSTAT= specification. */
2295 ffeste_io_iostat_is_temp_
= FALSE
;
2296 ffeste_io_iostat_
= ffecom_expr
2297 (info
->beru_spec
[FFESTP_beruixIOSTAT
].u
.expr
);
2299 else if (ffeste_io_abort_
!= NULL_TREE
)
2301 /* Have no IOSTAT= but have ERR=. */
2303 ffeste_io_iostat_is_temp_
= TRUE
;
2305 = ffecom_make_tempvar ("beru", ffecom_integer_type_node
,
2306 FFETARGET_charactersizeNONE
, -1);
2310 /* No IOSTAT= or ERR= specification. */
2312 ffeste_io_iostat_is_temp_
= FALSE
;
2313 ffeste_io_iostat_
= NULL_TREE
;
2316 /* Now prescan, then convert, all the arguments. */
2318 alist
= ffeste_io_ialist_ (errl
|| iostat
, FFESTV_unitINTEXPR
,
2319 info
->beru_spec
[FFESTP_beruixUNIT
].u
.expr
, 6);
2321 /* Don't generate "if (iostat != 0) goto label;" if label is temp abort
2322 label, since we're gonna fall through to there anyway. */
2324 ffeste_io_call_ (ffecom_call_gfrt (rt
, alist
, NULL_TREE
),
2325 ! ffeste_io_abort_is_temp_
);
2327 /* If we've got a temp label, generate its code here. */
2329 if (ffeste_io_abort_is_temp_
)
2331 DECL_INITIAL (ffeste_io_abort_
) = error_mark_node
;
2333 expand_label (ffeste_io_abort_
);
2335 assert (ffeste_io_err_
== NULL_TREE
);
2338 ffeste_end_stmt_ ();
2343 Also invoked by _labeldef_branch_finish_ (or, in cases
2344 of errors, other _labeldef_ functions) when the label definition is
2345 for a DO-target (LOOPEND) label, once per matching/outstanding DO
2346 block on the stack. */
2349 ffeste_do (ffestw block
)
2351 ffeste_emit_line_note_ ();
2353 if (ffestw_do_tvar (block
) == 0)
2355 expand_end_loop (); /* DO WHILE and just DO. */
2357 ffeste_end_block_ (block
);
2360 ffeste_end_iterdo_ (block
,
2361 ffestw_do_tvar (block
),
2362 ffestw_do_incr_saved (block
),
2363 ffestw_do_count_var (block
));
2366 /* End of statement following logical IF.
2368 Applies to *only* logical IF, not to IF-THEN. */
2371 ffeste_end_R807 (void)
2373 ffeste_emit_line_note_ ();
2377 ffeste_end_block_ (NULL
);
2380 /* Generate "code" for branch label definition. */
2383 ffeste_labeldef_branch (ffelab label
)
2387 glabel
= ffecom_lookup_label (label
);
2388 assert (glabel
!= NULL_TREE
);
2389 if (TREE_CODE (glabel
) == ERROR_MARK
)
2392 assert (DECL_INITIAL (glabel
) == NULL_TREE
);
2394 DECL_INITIAL (glabel
) = error_mark_node
;
2395 DECL_SOURCE_FILE (glabel
) = ffelab_definition_filename (label
);
2396 DECL_SOURCE_LINE (glabel
) = ffelab_definition_filelinenum (label
);
2400 expand_label (glabel
);
2403 /* Generate "code" for FORMAT label definition. */
2406 ffeste_labeldef_format (ffelab label
)
2408 ffeste_label_formatdef_
= label
;
2411 /* Assignment statement (outside of WHERE). */
2414 ffeste_R737A (ffebld dest
, ffebld source
)
2416 ffeste_check_simple_ ();
2418 ffeste_emit_line_note_ ();
2420 ffeste_start_stmt_ ();
2422 ffecom_expand_let_stmt (dest
, source
);
2424 ffeste_end_stmt_ ();
2427 /* Block IF (IF-THEN) statement. */
2430 ffeste_R803 (ffestw block
, ffebld expr
)
2434 ffeste_check_simple_ ();
2436 ffeste_emit_line_note_ ();
2438 ffeste_start_block_ (block
);
2440 temp
= ffecom_make_tempvar ("ifthen", integer_type_node
,
2441 FFETARGET_charactersizeNONE
, -1);
2443 ffeste_start_stmt_ ();
2445 ffecom_prepare_expr (expr
);
2447 if (ffecom_prepare_end ())
2451 result
= ffecom_modify (void_type_node
,
2453 ffecom_truth_value (ffecom_expr (expr
)));
2455 expand_expr_stmt (result
);
2457 ffeste_end_stmt_ ();
2461 ffeste_end_stmt_ ();
2463 temp
= ffecom_truth_value (ffecom_expr (expr
));
2466 expand_start_cond (temp
, 0);
2468 /* No fake `else' constructs introduced (yet). */
2469 ffestw_set_ifthen_fake_else (block
, 0);
2472 /* ELSE IF statement. */
2475 ffeste_R804 (ffestw block
, ffebld expr
)
2479 ffeste_check_simple_ ();
2481 ffeste_emit_line_note_ ();
2483 /* Since ELSEIF(expr) might require preparations for expr,
2484 implement as ELSE; prepare-expr; IF (expr) THEN ...; ENDIF. */
2486 expand_start_else ();
2488 ffeste_start_block_ (block
);
2490 temp
= ffecom_make_tempvar ("elseif", integer_type_node
,
2491 FFETARGET_charactersizeNONE
, -1);
2493 ffeste_start_stmt_ ();
2495 ffecom_prepare_expr (expr
);
2497 if (ffecom_prepare_end ())
2501 result
= ffecom_modify (void_type_node
,
2503 ffecom_truth_value (ffecom_expr (expr
)));
2505 expand_expr_stmt (result
);
2507 ffeste_end_stmt_ ();
2511 /* In this case, we could probably have used expand_start_elseif
2512 instead, saving the need for a fake `else' construct. But,
2513 until it's clear that'd improve performance, it's easier this
2514 way, since we have to expand_start_else before we get to this
2515 test, given the current design. */
2517 ffeste_end_stmt_ ();
2519 temp
= ffecom_truth_value (ffecom_expr (expr
));
2522 expand_start_cond (temp
, 0);
2524 /* Increment number of fake `else' constructs introduced. */
2525 ffestw_set_ifthen_fake_else (block
,
2526 ffestw_ifthen_fake_else (block
) + 1);
2529 /* ELSE statement. */
2532 ffeste_R805 (ffestw block UNUSED
)
2534 ffeste_check_simple_ ();
2536 ffeste_emit_line_note_ ();
2538 expand_start_else ();
2541 /* END IF statement. */
2544 ffeste_R806 (ffestw block
)
2546 int i
= ffestw_ifthen_fake_else (block
) + 1;
2548 ffeste_emit_line_note_ ();
2554 ffeste_end_block_ (block
);
2558 /* Logical IF statement. */
2561 ffeste_R807 (ffebld expr
)
2565 ffeste_check_simple_ ();
2567 ffeste_emit_line_note_ ();
2569 ffeste_start_block_ (NULL
);
2571 temp
= ffecom_make_tempvar ("if", integer_type_node
,
2572 FFETARGET_charactersizeNONE
, -1);
2574 ffeste_start_stmt_ ();
2576 ffecom_prepare_expr (expr
);
2578 if (ffecom_prepare_end ())
2582 result
= ffecom_modify (void_type_node
,
2584 ffecom_truth_value (ffecom_expr (expr
)));
2586 expand_expr_stmt (result
);
2588 ffeste_end_stmt_ ();
2592 ffeste_end_stmt_ ();
2594 temp
= ffecom_truth_value (ffecom_expr (expr
));
2597 expand_start_cond (temp
, 0);
2600 /* SELECT CASE statement. */
2603 ffeste_R809 (ffestw block
, ffebld expr
)
2605 ffeste_check_simple_ ();
2607 ffeste_emit_line_note_ ();
2609 ffeste_start_block_ (block
);
2612 || (ffeinfo_basictype (ffebld_info (expr
))
2613 == FFEINFO_basictypeANY
))
2614 ffestw_set_select_texpr (block
, error_mark_node
);
2615 else if (ffeinfo_basictype (ffebld_info (expr
))
2616 == FFEINFO_basictypeCHARACTER
)
2618 /* ~~~Someday handle CHARACTER*1, CHARACTER*N */
2620 /* xgettext:no-c-format */
2621 ffebad_start_msg ("SELECT CASE on CHARACTER type (at %0) not supported -- sorry",
2622 FFEBAD_severityFATAL
);
2623 ffebad_here (0, ffestw_line (block
), ffestw_col (block
));
2625 ffestw_set_select_texpr (block
, error_mark_node
);
2632 result
= ffecom_make_tempvar ("select", ffecom_type_expr (expr
),
2633 ffeinfo_size (ffebld_info (expr
)),
2636 ffeste_start_stmt_ ();
2638 ffecom_prepare_expr (expr
);
2640 ffecom_prepare_end ();
2642 texpr
= ffecom_expr (expr
);
2644 assert (TYPE_MAIN_VARIANT (TREE_TYPE (texpr
))
2645 == TYPE_MAIN_VARIANT (TREE_TYPE (result
)));
2647 texpr
= ffecom_modify (void_type_node
,
2650 expand_expr_stmt (texpr
);
2652 ffeste_end_stmt_ ();
2654 expand_start_case (1, result
, TREE_TYPE (result
),
2655 "SELECT CASE statement");
2656 ffestw_set_select_texpr (block
, texpr
);
2657 ffestw_set_select_break (block
, FALSE
);
2663 If casenum is 0, it's CASE DEFAULT. Else it's the case ranges at
2664 the start of the first_stmt list in the select object at the top of
2665 the stack that match casenum. */
2668 ffeste_R810 (ffestw block
, unsigned long casenum
)
2670 ffestwSelect s
= ffestw_select (block
);
2678 ffeste_check_simple_ ();
2680 if (s
->first_stmt
== (ffestwCase
) &s
->first_rel
)
2685 ffeste_emit_line_note_ ();
2687 if (ffestw_select_texpr (block
) == error_mark_node
)
2690 /* ~~~Someday handle CHARACTER*1, CHARACTER*N */
2692 tlabel
= build_decl (LABEL_DECL
, NULL_TREE
, NULL_TREE
);
2694 if (ffestw_select_break (block
))
2695 expand_exit_something ();
2697 ffestw_set_select_break (block
, TRUE
);
2699 if ((c
== NULL
) || (casenum
!= c
->casenum
))
2701 if (casenum
== 0) /* Intentional CASE DEFAULT. */
2703 pushok
= pushcase (NULL_TREE
, 0, tlabel
, &duplicate
);
2704 assert (pushok
== 0);
2710 texprlow
= (c
->low
== NULL
) ? NULL_TREE
2711 : ffecom_constantunion_with_type (&ffebld_constant_union (c
->low
),
2712 ffecom_tree_type
[s
->type
][s
->kindtype
],c
->low
->consttype
);
2713 if (c
->low
!= c
->high
)
2715 texprhigh
= (c
->high
== NULL
) ? NULL_TREE
2716 : ffecom_constantunion_with_type (&ffebld_constant_union (c
->high
),
2717 ffecom_tree_type
[s
->type
][s
->kindtype
],c
->high
->consttype
);
2718 pushok
= pushcase_range (texprlow
, texprhigh
, convert
,
2719 tlabel
, &duplicate
);
2722 pushok
= pushcase (texprlow
, convert
, tlabel
, &duplicate
);
2725 ffebad_start_msg ("SELECT (at %0) has duplicate cases -- check integer overflow of CASE(s)",
2726 FFEBAD_severityFATAL
);
2727 ffebad_here (0, ffestw_line (block
), ffestw_col (block
));
2729 ffestw_set_select_texpr (block
, error_mark_node
);
2733 c
->previous_stmt
->previous_stmt
->next_stmt
= c
;
2734 c
->previous_stmt
= c
->previous_stmt
->previous_stmt
;
2736 while ((c
!= (ffestwCase
) &s
->first_rel
) && (casenum
== c
->casenum
));
2739 /* END SELECT statement. */
2742 ffeste_R811 (ffestw block
)
2744 ffeste_emit_line_note_ ();
2746 /* ~~~Someday handle CHARACTER*1, CHARACTER*N */
2748 if (TREE_CODE (ffestw_select_texpr (block
)) != ERROR_MARK
)
2749 expand_end_case (ffestw_select_texpr (block
));
2751 ffeste_end_block_ (block
);
2754 /* Iterative DO statement. */
2757 ffeste_R819A (ffestw block
, ffelab label UNUSED
, ffebld var
,
2758 ffebld start
, ffelexToken start_token
,
2759 ffebld end
, ffelexToken end_token
,
2760 ffebld incr
, ffelexToken incr_token
)
2762 ffeste_check_simple_ ();
2764 ffeste_emit_line_note_ ();
2766 ffeste_begin_iterdo_ (block
, NULL
, NULL
, NULL
,
2771 "Iterative DO loop");
2774 /* DO WHILE statement. */
2777 ffeste_R819B (ffestw block
, ffelab label UNUSED
, ffebld expr
)
2781 ffeste_check_simple_ ();
2783 ffeste_emit_line_note_ ();
2785 ffeste_start_block_ (block
);
2789 struct nesting
*loop
;
2792 result
= ffecom_make_tempvar ("dowhile", integer_type_node
,
2793 FFETARGET_charactersizeNONE
, -1);
2794 loop
= expand_start_loop (1);
2796 ffeste_start_stmt_ ();
2798 ffecom_prepare_expr (expr
);
2800 ffecom_prepare_end ();
2802 mod
= ffecom_modify (void_type_node
,
2804 ffecom_truth_value (ffecom_expr (expr
)));
2805 expand_expr_stmt (mod
);
2807 ffeste_end_stmt_ ();
2809 ffestw_set_do_hook (block
, loop
);
2810 expand_exit_loop_top_cond (0, result
);
2813 ffestw_set_do_hook (block
, expand_start_loop (1));
2815 ffestw_set_do_tvar (block
, NULL_TREE
);
2818 /* END DO statement.
2820 This is the MIL-STD 1753 END DO. It's syntactic sugar, similar to
2821 CONTINUE (except that it has to have a label that is the target of
2822 one or more iterative DO statement), not the Fortran-90 structured
2823 END DO, which is handled elsewhere, as is the actual mechanism of
2824 ending an iterative DO statement, even one that ends at a label. */
2829 ffeste_check_simple_ ();
2831 ffeste_emit_line_note_ ();
2836 /* CYCLE statement. */
2839 ffeste_R834 (ffestw block
)
2841 ffeste_check_simple_ ();
2843 ffeste_emit_line_note_ ();
2845 expand_continue_loop (ffestw_do_hook (block
));
2848 /* EXIT statement. */
2851 ffeste_R835 (ffestw block
)
2853 ffeste_check_simple_ ();
2855 ffeste_emit_line_note_ ();
2857 expand_exit_loop (ffestw_do_hook (block
));
2860 /* GOTO statement. */
2863 ffeste_R836 (ffelab label
)
2867 ffeste_check_simple_ ();
2869 ffeste_emit_line_note_ ();
2871 glabel
= ffecom_lookup_label (label
);
2872 if ((glabel
!= NULL_TREE
)
2873 && (TREE_CODE (glabel
) != ERROR_MARK
))
2875 expand_goto (glabel
);
2876 TREE_USED (glabel
) = 1;
2880 /* Computed GOTO statement. */
2883 ffeste_R837 (ffelab
*labels
, int count
, ffebld expr
)
2892 ffeste_check_simple_ ();
2894 ffeste_emit_line_note_ ();
2896 ffeste_start_stmt_ ();
2898 ffecom_prepare_expr (expr
);
2900 ffecom_prepare_end ();
2902 texpr
= ffecom_expr (expr
);
2904 expand_start_case (0, texpr
, TREE_TYPE (texpr
), "computed GOTO statement");
2906 for (i
= 0; i
< count
; ++i
)
2908 value
= build_int_2 (i
+ 1, 0);
2909 tlabel
= build_decl (LABEL_DECL
, NULL_TREE
, NULL_TREE
);
2911 pushok
= pushcase (value
, convert
, tlabel
, &duplicate
);
2912 assert (pushok
== 0);
2914 tlabel
= ffecom_lookup_label (labels
[i
]);
2915 if ((tlabel
== NULL_TREE
)
2916 || (TREE_CODE (tlabel
) == ERROR_MARK
))
2919 expand_goto (tlabel
);
2920 TREE_USED (tlabel
) = 1;
2922 expand_end_case (texpr
);
2924 ffeste_end_stmt_ ();
2927 /* ASSIGN statement. */
2930 ffeste_R838 (ffelab label
, ffebld target
)
2936 ffeste_check_simple_ ();
2938 ffeste_emit_line_note_ ();
2940 /* No need to call ffeste_start_stmt_(), as the sorts of expressions
2941 seen here should never require use of temporaries. */
2943 label_tree
= ffecom_lookup_label (label
);
2944 if ((label_tree
!= NULL_TREE
)
2945 && (TREE_CODE (label_tree
) != ERROR_MARK
))
2947 label_tree
= ffecom_1 (ADDR_EXPR
,
2948 build_pointer_type (void_type_node
),
2950 TREE_CONSTANT (label_tree
) = 1;
2952 target_tree
= ffecom_expr_assign_w (target
);
2953 if (TREE_CODE (target_tree
) != ERROR_MARK
)
2955 if (GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (target_tree
)))
2956 < GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (label_tree
))))
2957 error ("ASSIGN to variable that is too small");
2959 label_tree
= convert (TREE_TYPE (target_tree
), label_tree
);
2961 expr_tree
= ffecom_modify (void_type_node
,
2964 expand_expr_stmt (expr_tree
);
2969 /* Assigned GOTO statement. */
2972 ffeste_R839 (ffebld target
)
2976 ffeste_check_simple_ ();
2978 ffeste_emit_line_note_ ();
2980 /* No need to call ffeste_start_stmt_(), as the sorts of expressions
2981 seen here should never require use of temporaries. */
2983 t
= ffecom_expr_assign (target
);
2985 if (TREE_CODE (t
) != ERROR_MARK
)
2987 if (GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (t
)))
2988 < GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node
))))
2989 error ("ASSIGNed GOTO target variable is too small");
2991 expand_computed_goto (convert (TREE_TYPE (null_pointer_node
), t
));
2995 /* Arithmetic IF statement. */
2998 ffeste_R840 (ffebld expr
, ffelab neg
, ffelab zero
, ffelab pos
)
3000 tree gneg
= ffecom_lookup_label (neg
);
3001 tree gzero
= ffecom_lookup_label (zero
);
3002 tree gpos
= ffecom_lookup_label (pos
);
3005 ffeste_check_simple_ ();
3007 ffeste_emit_line_note_ ();
3009 if ((gneg
== NULL_TREE
) || (gzero
== NULL_TREE
) || (gpos
== NULL_TREE
))
3011 if ((TREE_CODE (gneg
) == ERROR_MARK
)
3012 || (TREE_CODE (gzero
) == ERROR_MARK
)
3013 || (TREE_CODE (gpos
) == ERROR_MARK
))
3016 ffeste_start_stmt_ ();
3018 ffecom_prepare_expr (expr
);
3020 ffecom_prepare_end ();
3025 expand_goto (gzero
);
3028 /* IF (expr.LE.0) THEN GOTO neg/zero ELSE GOTO pos. */
3029 texpr
= ffecom_expr (expr
);
3030 texpr
= ffecom_2 (LE_EXPR
, integer_type_node
,
3032 convert (TREE_TYPE (texpr
),
3033 integer_zero_node
));
3034 expand_start_cond (ffecom_truth_value (texpr
), 0);
3035 expand_goto (gzero
);
3036 expand_start_else ();
3041 else if (neg
== pos
)
3043 /* IF (expr.NE.0) THEN GOTO neg/pos ELSE GOTO zero. */
3044 texpr
= ffecom_expr (expr
);
3045 texpr
= ffecom_2 (NE_EXPR
, integer_type_node
,
3047 convert (TREE_TYPE (texpr
),
3048 integer_zero_node
));
3049 expand_start_cond (ffecom_truth_value (texpr
), 0);
3051 expand_start_else ();
3052 expand_goto (gzero
);
3055 else if (zero
== pos
)
3057 /* IF (expr.GE.0) THEN GOTO zero/pos ELSE GOTO neg. */
3058 texpr
= ffecom_expr (expr
);
3059 texpr
= ffecom_2 (GE_EXPR
, integer_type_node
,
3061 convert (TREE_TYPE (texpr
),
3062 integer_zero_node
));
3063 expand_start_cond (ffecom_truth_value (texpr
), 0);
3064 expand_goto (gzero
);
3065 expand_start_else ();
3071 /* Use a SAVE_EXPR in combo with:
3072 IF (expr.LT.0) THEN GOTO neg
3073 ELSEIF (expr.GT.0) THEN GOTO pos
3075 tree expr_saved
= ffecom_save_tree (ffecom_expr (expr
));
3077 texpr
= ffecom_2 (LT_EXPR
, integer_type_node
,
3079 convert (TREE_TYPE (expr_saved
),
3080 integer_zero_node
));
3081 expand_start_cond (ffecom_truth_value (texpr
), 0);
3083 texpr
= ffecom_2 (GT_EXPR
, integer_type_node
,
3085 convert (TREE_TYPE (expr_saved
),
3086 integer_zero_node
));
3087 expand_start_elseif (ffecom_truth_value (texpr
));
3089 expand_start_else ();
3090 expand_goto (gzero
);
3094 ffeste_end_stmt_ ();
3097 /* CONTINUE statement. */
3102 ffeste_check_simple_ ();
3104 ffeste_emit_line_note_ ();
3109 /* STOP statement. */
3112 ffeste_R842 (ffebld expr
)
3117 ffeste_check_simple_ ();
3119 ffeste_emit_line_note_ ();
3122 || (ffeinfo_basictype (ffebld_info (expr
))
3123 == FFEINFO_basictypeANY
))
3125 msg
= ffelex_token_new_character ("",
3126 ffelex_token_where_line (ffesta_tokens
[0]),
3127 ffelex_token_where_column (ffesta_tokens
[0]));
3128 expr
= ffebld_new_conter (ffebld_constant_new_characterdefault
3130 ffelex_token_kill (msg
);
3131 ffebld_set_info (expr
, ffeinfo_new (FFEINFO_basictypeCHARACTER
,
3132 FFEINFO_kindtypeCHARACTERDEFAULT
,
3133 0, FFEINFO_kindENTITY
,
3134 FFEINFO_whereCONSTANT
, 0));
3136 else if (ffeinfo_basictype (ffebld_info (expr
))
3137 == FFEINFO_basictypeINTEGER
)
3141 assert (ffebld_op (expr
) == FFEBLD_opCONTER
);
3142 assert (ffeinfo_kindtype (ffebld_info (expr
))
3143 == FFEINFO_kindtypeINTEGERDEFAULT
);
3144 sprintf (num
, "%" ffetargetIntegerDefault_f
"d",
3145 ffebld_constant_integer1 (ffebld_conter (expr
)));
3146 msg
= ffelex_token_new_character (num
,
3147 ffelex_token_where_line (ffesta_tokens
[0]),
3148 ffelex_token_where_column (ffesta_tokens
[0]));
3149 expr
= ffebld_new_conter (ffebld_constant_new_characterdefault (msg
));
3150 ffelex_token_kill (msg
);
3151 ffebld_set_info (expr
, ffeinfo_new (FFEINFO_basictypeCHARACTER
,
3152 FFEINFO_kindtypeCHARACTERDEFAULT
,
3153 0, FFEINFO_kindENTITY
,
3154 FFEINFO_whereCONSTANT
, 0));
3158 assert (ffeinfo_basictype (ffebld_info (expr
))
3159 == FFEINFO_basictypeCHARACTER
);
3160 assert (ffebld_op (expr
) == FFEBLD_opCONTER
);
3161 assert (ffeinfo_kindtype (ffebld_info (expr
))
3162 == FFEINFO_kindtypeCHARACTERDEFAULT
);
3165 /* No need to call ffeste_start_stmt_(), as the sorts of expressions
3166 seen here should never require use of temporaries. */
3168 callit
= ffecom_call_gfrt (FFECOM_gfrtSTOP
,
3169 ffecom_list_ptr_to_expr (ffebld_new_item (expr
, NULL
)),
3171 TREE_SIDE_EFFECTS (callit
) = 1;
3173 expand_expr_stmt (callit
);
3176 /* PAUSE statement. */
3179 ffeste_R843 (ffebld expr
)
3184 ffeste_check_simple_ ();
3186 ffeste_emit_line_note_ ();
3189 || (ffeinfo_basictype (ffebld_info (expr
))
3190 == FFEINFO_basictypeANY
))
3192 msg
= ffelex_token_new_character ("",
3193 ffelex_token_where_line (ffesta_tokens
[0]),
3194 ffelex_token_where_column (ffesta_tokens
[0]));
3195 expr
= ffebld_new_conter (ffebld_constant_new_characterdefault (msg
));
3196 ffelex_token_kill (msg
);
3197 ffebld_set_info (expr
, ffeinfo_new (FFEINFO_basictypeCHARACTER
,
3198 FFEINFO_kindtypeCHARACTERDEFAULT
,
3199 0, FFEINFO_kindENTITY
,
3200 FFEINFO_whereCONSTANT
, 0));
3202 else if (ffeinfo_basictype (ffebld_info (expr
)) == FFEINFO_basictypeINTEGER
)
3206 assert (ffebld_op (expr
) == FFEBLD_opCONTER
);
3207 assert (ffeinfo_kindtype (ffebld_info (expr
))
3208 == FFEINFO_kindtypeINTEGERDEFAULT
);
3209 sprintf (num
, "%" ffetargetIntegerDefault_f
"d",
3210 ffebld_constant_integer1 (ffebld_conter (expr
)));
3211 msg
= ffelex_token_new_character (num
, ffelex_token_where_line (ffesta_tokens
[0]),
3212 ffelex_token_where_column (ffesta_tokens
[0]));
3213 expr
= ffebld_new_conter (ffebld_constant_new_characterdefault (msg
));
3214 ffelex_token_kill (msg
);
3215 ffebld_set_info (expr
, ffeinfo_new (FFEINFO_basictypeCHARACTER
,
3216 FFEINFO_kindtypeCHARACTERDEFAULT
,
3217 0, FFEINFO_kindENTITY
,
3218 FFEINFO_whereCONSTANT
, 0));
3222 assert (ffeinfo_basictype (ffebld_info (expr
))
3223 == FFEINFO_basictypeCHARACTER
);
3224 assert (ffebld_op (expr
) == FFEBLD_opCONTER
);
3225 assert (ffeinfo_kindtype (ffebld_info (expr
))
3226 == FFEINFO_kindtypeCHARACTERDEFAULT
);
3229 /* No need to call ffeste_start_stmt_(), as the sorts of expressions
3230 seen here should never require use of temporaries. */
3232 callit
= ffecom_call_gfrt (FFECOM_gfrtPAUSE
,
3233 ffecom_list_ptr_to_expr (ffebld_new_item (expr
, NULL
)),
3235 TREE_SIDE_EFFECTS (callit
) = 1;
3237 expand_expr_stmt (callit
);
3240 /* OPEN statement. */
3243 ffeste_R904 (ffestpOpenStmt
*info
)
3249 ffeste_check_simple_ ();
3251 ffeste_emit_line_note_ ();
3253 #define specified(something) (info->open_spec[something].kw_or_val_present)
3255 iostat
= specified (FFESTP_openixIOSTAT
);
3256 errl
= specified (FFESTP_openixERR
);
3260 ffeste_start_stmt_ ();
3266 = ffecom_lookup_label
3267 (info
->open_spec
[FFESTP_openixERR
].u
.label
);
3268 ffeste_io_abort_is_temp_
= FALSE
;
3272 ffeste_io_err_
= NULL_TREE
;
3274 if ((ffeste_io_abort_is_temp_
= iostat
))
3275 ffeste_io_abort_
= ffecom_temp_label ();
3277 ffeste_io_abort_
= NULL_TREE
;
3282 /* Have IOSTAT= specification. */
3284 ffeste_io_iostat_is_temp_
= FALSE
;
3285 ffeste_io_iostat_
= ffecom_expr
3286 (info
->open_spec
[FFESTP_openixIOSTAT
].u
.expr
);
3288 else if (ffeste_io_abort_
!= NULL_TREE
)
3290 /* Have no IOSTAT= but have ERR=. */
3292 ffeste_io_iostat_is_temp_
= TRUE
;
3294 = ffecom_make_tempvar ("open", ffecom_integer_type_node
,
3295 FFETARGET_charactersizeNONE
, -1);
3299 /* No IOSTAT= or ERR= specification. */
3301 ffeste_io_iostat_is_temp_
= FALSE
;
3302 ffeste_io_iostat_
= NULL_TREE
;
3305 /* Now prescan, then convert, all the arguments. */
3307 args
= ffeste_io_olist_ (errl
|| iostat
,
3308 info
->open_spec
[FFESTP_openixUNIT
].u
.expr
,
3309 &info
->open_spec
[FFESTP_openixFILE
],
3310 &info
->open_spec
[FFESTP_openixSTATUS
],
3311 &info
->open_spec
[FFESTP_openixACCESS
],
3312 &info
->open_spec
[FFESTP_openixFORM
],
3313 &info
->open_spec
[FFESTP_openixRECL
],
3314 &info
->open_spec
[FFESTP_openixBLANK
]);
3316 /* Don't generate "if (iostat != 0) goto label;" if label is temp abort
3317 label, since we're gonna fall through to there anyway. */
3319 ffeste_io_call_ (ffecom_call_gfrt (FFECOM_gfrtFOPEN
, args
, NULL_TREE
),
3320 ! ffeste_io_abort_is_temp_
);
3322 /* If we've got a temp label, generate its code here. */
3324 if (ffeste_io_abort_is_temp_
)
3326 DECL_INITIAL (ffeste_io_abort_
) = error_mark_node
;
3328 expand_label (ffeste_io_abort_
);
3330 assert (ffeste_io_err_
== NULL_TREE
);
3333 ffeste_end_stmt_ ();
3336 /* CLOSE statement. */
3339 ffeste_R907 (ffestpCloseStmt
*info
)
3345 ffeste_check_simple_ ();
3347 ffeste_emit_line_note_ ();
3349 #define specified(something) (info->close_spec[something].kw_or_val_present)
3351 iostat
= specified (FFESTP_closeixIOSTAT
);
3352 errl
= specified (FFESTP_closeixERR
);
3356 ffeste_start_stmt_ ();
3362 = ffecom_lookup_label
3363 (info
->close_spec
[FFESTP_closeixERR
].u
.label
);
3364 ffeste_io_abort_is_temp_
= FALSE
;
3368 ffeste_io_err_
= NULL_TREE
;
3370 if ((ffeste_io_abort_is_temp_
= iostat
))
3371 ffeste_io_abort_
= ffecom_temp_label ();
3373 ffeste_io_abort_
= NULL_TREE
;
3378 /* Have IOSTAT= specification. */
3380 ffeste_io_iostat_is_temp_
= FALSE
;
3381 ffeste_io_iostat_
= ffecom_expr
3382 (info
->close_spec
[FFESTP_closeixIOSTAT
].u
.expr
);
3384 else if (ffeste_io_abort_
!= NULL_TREE
)
3386 /* Have no IOSTAT= but have ERR=. */
3388 ffeste_io_iostat_is_temp_
= TRUE
;
3390 = ffecom_make_tempvar ("close", ffecom_integer_type_node
,
3391 FFETARGET_charactersizeNONE
, -1);
3395 /* No IOSTAT= or ERR= specification. */
3397 ffeste_io_iostat_is_temp_
= FALSE
;
3398 ffeste_io_iostat_
= NULL_TREE
;
3401 /* Now prescan, then convert, all the arguments. */
3403 args
= ffeste_io_cllist_ (errl
|| iostat
,
3404 info
->close_spec
[FFESTP_closeixUNIT
].u
.expr
,
3405 &info
->close_spec
[FFESTP_closeixSTATUS
]);
3407 /* Don't generate "if (iostat != 0) goto label;" if label is temp abort
3408 label, since we're gonna fall through to there anyway. */
3410 ffeste_io_call_ (ffecom_call_gfrt (FFECOM_gfrtFCLOS
, args
, NULL_TREE
),
3411 ! ffeste_io_abort_is_temp_
);
3413 /* If we've got a temp label, generate its code here. */
3415 if (ffeste_io_abort_is_temp_
)
3417 DECL_INITIAL (ffeste_io_abort_
) = error_mark_node
;
3419 expand_label (ffeste_io_abort_
);
3421 assert (ffeste_io_err_
== NULL_TREE
);
3424 ffeste_end_stmt_ ();
3427 /* READ(...) statement -- start. */
3430 ffeste_R909_start (ffestpReadStmt
*info
, bool only_format UNUSED
,
3431 ffestvUnit unit
, ffestvFormat format
, bool rec
,
3441 ffeste_check_start_ ();
3443 ffeste_emit_line_note_ ();
3445 /* First determine the start, per-item, and end run-time functions to
3446 call. The per-item function is picked by choosing an ffeste function
3447 to call to handle a given item; it knows how to generate a call to the
3448 appropriate run-time function, and is called an "I/O driver". */
3452 case FFESTV_formatNONE
: /* no FMT= */
3453 ffeste_io_driver_
= ffeste_io_douio_
;
3455 start
= FFECOM_gfrtSRDUE
, end
= FFECOM_gfrtERDUE
;
3457 start
= FFECOM_gfrtSRSUE
, end
= FFECOM_gfrtERSUE
;
3460 case FFESTV_formatLABEL
: /* FMT=10 */
3461 case FFESTV_formatCHAREXPR
: /* FMT='(I10)' */
3462 case FFESTV_formatINTEXPR
: /* FMT=I [after ASSIGN 10 TO I] */
3463 ffeste_io_driver_
= ffeste_io_dofio_
;
3465 start
= FFECOM_gfrtSRDFE
, end
= FFECOM_gfrtERDFE
;
3466 else if (unit
== FFESTV_unitCHAREXPR
)
3467 start
= FFECOM_gfrtSRSFI
, end
= FFECOM_gfrtERSFI
;
3469 start
= FFECOM_gfrtSRSFE
, end
= FFECOM_gfrtERSFE
;
3472 case FFESTV_formatASTERISK
: /* FMT=* */
3473 ffeste_io_driver_
= ffeste_io_dolio_
;
3474 if (unit
== FFESTV_unitCHAREXPR
)
3475 start
= FFECOM_gfrtSRSLI
, end
= FFECOM_gfrtERSLI
;
3477 start
= FFECOM_gfrtSRSLE
, end
= FFECOM_gfrtERSLE
;
3480 case FFESTV_formatNAMELIST
: /* FMT=FOO or NML=FOO [NAMELIST
3482 ffeste_io_driver_
= NULL
; /* No start or driver function. */
3483 start
= FFECOM_gfrtSRSNE
, end
= FFECOM_gfrt
;
3487 assert ("Weird stuff" == NULL
);
3488 start
= FFECOM_gfrt
, end
= FFECOM_gfrt
;
3491 ffeste_io_endgfrt_
= end
;
3493 #define specified(something) (info->read_spec[something].kw_or_val_present)
3495 iostat
= specified (FFESTP_readixIOSTAT
);
3496 errl
= specified (FFESTP_readixERR
);
3497 endl
= specified (FFESTP_readixEND
);
3501 ffeste_start_stmt_ ();
3505 /* Have ERR= specification. */
3508 = ffecom_lookup_label (info
->read_spec
[FFESTP_readixERR
].u
.label
);
3512 /* Have both ERR= and END=. Need a temp label to handle both. */
3514 = ffecom_lookup_label (info
->read_spec
[FFESTP_readixEND
].u
.label
);
3515 ffeste_io_abort_is_temp_
= TRUE
;
3516 ffeste_io_abort_
= ffecom_temp_label ();
3520 /* Have ERR= but no END=. */
3521 ffeste_io_end_
= NULL_TREE
;
3522 if ((ffeste_io_abort_is_temp_
= iostat
))
3523 ffeste_io_abort_
= ffecom_temp_label ();
3525 ffeste_io_abort_
= ffeste_io_err_
;
3530 /* No ERR= specification. */
3532 ffeste_io_err_
= NULL_TREE
;
3535 /* Have END= but no ERR=. */
3537 = ffecom_lookup_label (info
->read_spec
[FFESTP_readixEND
].u
.label
);
3538 if ((ffeste_io_abort_is_temp_
= iostat
))
3539 ffeste_io_abort_
= ffecom_temp_label ();
3541 ffeste_io_abort_
= ffeste_io_end_
;
3545 /* Have no ERR= or END=. */
3547 ffeste_io_end_
= NULL_TREE
;
3548 if ((ffeste_io_abort_is_temp_
= iostat
))
3549 ffeste_io_abort_
= ffecom_temp_label ();
3551 ffeste_io_abort_
= NULL_TREE
;
3557 /* Have IOSTAT= specification. */
3559 ffeste_io_iostat_is_temp_
= FALSE
;
3561 = ffecom_expr (info
->read_spec
[FFESTP_readixIOSTAT
].u
.expr
);
3563 else if (ffeste_io_abort_
!= NULL_TREE
)
3565 /* Have no IOSTAT= but have ERR= and/or END=. */
3567 ffeste_io_iostat_is_temp_
= TRUE
;
3569 = ffecom_make_tempvar ("read", ffecom_integer_type_node
,
3570 FFETARGET_charactersizeNONE
, -1);
3574 /* No IOSTAT=, ERR=, or END= specification. */
3576 ffeste_io_iostat_is_temp_
= FALSE
;
3577 ffeste_io_iostat_
= NULL_TREE
;
3580 /* Now prescan, then convert, all the arguments. */
3582 if (unit
== FFESTV_unitCHAREXPR
)
3583 cilist
= ffeste_io_icilist_ (errl
|| iostat
,
3584 info
->read_spec
[FFESTP_readixUNIT
].u
.expr
,
3585 endl
|| iostat
, format
,
3586 &info
->read_spec
[FFESTP_readixFORMAT
]);
3588 cilist
= ffeste_io_cilist_ (errl
|| iostat
, unit
,
3589 info
->read_spec
[FFESTP_readixUNIT
].u
.expr
,
3590 5, endl
|| iostat
, format
,
3591 &info
->read_spec
[FFESTP_readixFORMAT
],
3593 info
->read_spec
[FFESTP_readixREC
].u
.expr
);
3595 /* If there is no end function, then there are no item functions (i.e.
3596 it's a NAMELIST), and vice versa by the way. In this situation, don't
3597 generate the "if (iostat != 0) goto label;" if the label is temp abort
3598 label, since we're gonna fall through to there anyway. */
3600 ffeste_io_call_ (ffecom_call_gfrt (start
, cilist
, NULL_TREE
),
3601 (! ffeste_io_abort_is_temp_
) || (end
!= FFECOM_gfrt
));
3604 /* READ statement -- I/O item. */
3607 ffeste_R909_item (ffebld expr
, ffelexToken expr_token
)
3609 ffeste_check_item_ ();
3614 /* Strip parens off items such as in "READ *,(A)". This is really a bug
3615 in the user's code, but I've been told lots of code does this. */
3616 while (ffebld_op (expr
) == FFEBLD_opPAREN
)
3617 expr
= ffebld_left (expr
);
3619 if (ffebld_op (expr
) == FFEBLD_opANY
)
3622 if (ffebld_op (expr
) == FFEBLD_opIMPDO
)
3623 ffeste_io_impdo_ (expr
, expr_token
);
3626 ffeste_start_stmt_ ();
3628 ffecom_prepare_arg_ptr_to_expr (expr
);
3630 ffecom_prepare_end ();
3632 ffeste_io_call_ ((*ffeste_io_driver_
) (expr
), TRUE
);
3634 ffeste_end_stmt_ ();
3638 /* READ statement -- end. */
3641 ffeste_R909_finish (void)
3643 ffeste_check_finish_ ();
3645 /* Don't generate "if (iostat != 0) goto label;" if label is temp abort
3646 label, since we're gonna fall through to there anyway. */
3648 if (ffeste_io_endgfrt_
!= FFECOM_gfrt
)
3649 ffeste_io_call_ (ffecom_call_gfrt (ffeste_io_endgfrt_
, NULL_TREE
,
3651 ! ffeste_io_abort_is_temp_
);
3653 /* If we've got a temp label, generate its code here and have it fan out
3654 to the END= or ERR= label as appropriate. */
3656 if (ffeste_io_abort_is_temp_
)
3658 DECL_INITIAL (ffeste_io_abort_
) = error_mark_node
;
3660 expand_label (ffeste_io_abort_
);
3662 /* "if (iostat<0) goto end_label;". */
3664 if ((ffeste_io_end_
!= NULL_TREE
)
3665 && (TREE_CODE (ffeste_io_end_
) != ERROR_MARK
))
3667 expand_start_cond (ffecom_truth_value
3668 (ffecom_2 (LT_EXPR
, integer_type_node
,
3670 ffecom_integer_zero_node
)),
3672 expand_goto (ffeste_io_end_
);
3676 /* "if (iostat>0) goto err_label;". */
3678 if ((ffeste_io_err_
!= NULL_TREE
)
3679 && (TREE_CODE (ffeste_io_err_
) != ERROR_MARK
))
3681 expand_start_cond (ffecom_truth_value
3682 (ffecom_2 (GT_EXPR
, integer_type_node
,
3684 ffecom_integer_zero_node
)),
3686 expand_goto (ffeste_io_err_
);
3691 ffeste_end_stmt_ ();
3694 /* WRITE statement -- start. */
3697 ffeste_R910_start (ffestpWriteStmt
*info
, ffestvUnit unit
,
3698 ffestvFormat format
, bool rec
)
3706 ffeste_check_start_ ();
3708 ffeste_emit_line_note_ ();
3710 /* First determine the start, per-item, and end run-time functions to
3711 call. The per-item function is picked by choosing an ffeste function
3712 to call to handle a given item; it knows how to generate a call to the
3713 appropriate run-time function, and is called an "I/O driver". */
3717 case FFESTV_formatNONE
: /* no FMT= */
3718 ffeste_io_driver_
= ffeste_io_douio_
;
3720 start
= FFECOM_gfrtSWDUE
, end
= FFECOM_gfrtEWDUE
;
3722 start
= FFECOM_gfrtSWSUE
, end
= FFECOM_gfrtEWSUE
;
3725 case FFESTV_formatLABEL
: /* FMT=10 */
3726 case FFESTV_formatCHAREXPR
: /* FMT='(I10)' */
3727 case FFESTV_formatINTEXPR
: /* FMT=I [after ASSIGN 10 TO I] */
3728 ffeste_io_driver_
= ffeste_io_dofio_
;
3730 start
= FFECOM_gfrtSWDFE
, end
= FFECOM_gfrtEWDFE
;
3731 else if (unit
== FFESTV_unitCHAREXPR
)
3732 start
= FFECOM_gfrtSWSFI
, end
= FFECOM_gfrtEWSFI
;
3734 start
= FFECOM_gfrtSWSFE
, end
= FFECOM_gfrtEWSFE
;
3737 case FFESTV_formatASTERISK
: /* FMT=* */
3738 ffeste_io_driver_
= ffeste_io_dolio_
;
3739 if (unit
== FFESTV_unitCHAREXPR
)
3740 start
= FFECOM_gfrtSWSLI
, end
= FFECOM_gfrtEWSLI
;
3742 start
= FFECOM_gfrtSWSLE
, end
= FFECOM_gfrtEWSLE
;
3745 case FFESTV_formatNAMELIST
: /* FMT=FOO or NML=FOO [NAMELIST
3747 ffeste_io_driver_
= NULL
; /* No start or driver function. */
3748 start
= FFECOM_gfrtSWSNE
, end
= FFECOM_gfrt
;
3752 assert ("Weird stuff" == NULL
);
3753 start
= FFECOM_gfrt
, end
= FFECOM_gfrt
;
3756 ffeste_io_endgfrt_
= end
;
3758 #define specified(something) (info->write_spec[something].kw_or_val_present)
3760 iostat
= specified (FFESTP_writeixIOSTAT
);
3761 errl
= specified (FFESTP_writeixERR
);
3765 ffeste_start_stmt_ ();
3767 ffeste_io_end_
= NULL_TREE
;
3771 /* Have ERR= specification. */
3775 = ffecom_lookup_label
3776 (info
->write_spec
[FFESTP_writeixERR
].u
.label
);
3777 ffeste_io_abort_is_temp_
= FALSE
;
3781 /* No ERR= specification. */
3783 ffeste_io_err_
= NULL_TREE
;
3785 if ((ffeste_io_abort_is_temp_
= iostat
))
3786 ffeste_io_abort_
= ffecom_temp_label ();
3788 ffeste_io_abort_
= NULL_TREE
;
3793 /* Have IOSTAT= specification. */
3795 ffeste_io_iostat_is_temp_
= FALSE
;
3796 ffeste_io_iostat_
= ffecom_expr
3797 (info
->write_spec
[FFESTP_writeixIOSTAT
].u
.expr
);
3799 else if (ffeste_io_abort_
!= NULL_TREE
)
3801 /* Have no IOSTAT= but have ERR=. */
3803 ffeste_io_iostat_is_temp_
= TRUE
;
3805 = ffecom_make_tempvar ("write", ffecom_integer_type_node
,
3806 FFETARGET_charactersizeNONE
, -1);
3810 /* No IOSTAT= or ERR= specification. */
3812 ffeste_io_iostat_is_temp_
= FALSE
;
3813 ffeste_io_iostat_
= NULL_TREE
;
3816 /* Now prescan, then convert, all the arguments. */
3818 if (unit
== FFESTV_unitCHAREXPR
)
3819 cilist
= ffeste_io_icilist_ (errl
|| iostat
,
3820 info
->write_spec
[FFESTP_writeixUNIT
].u
.expr
,
3822 &info
->write_spec
[FFESTP_writeixFORMAT
]);
3824 cilist
= ffeste_io_cilist_ (errl
|| iostat
, unit
,
3825 info
->write_spec
[FFESTP_writeixUNIT
].u
.expr
,
3827 &info
->write_spec
[FFESTP_writeixFORMAT
],
3829 info
->write_spec
[FFESTP_writeixREC
].u
.expr
);
3831 /* If there is no end function, then there are no item functions (i.e.
3832 it's a NAMELIST), and vice versa by the way. In this situation, don't
3833 generate the "if (iostat != 0) goto label;" if the label is temp abort
3834 label, since we're gonna fall through to there anyway. */
3836 ffeste_io_call_ (ffecom_call_gfrt (start
, cilist
, NULL_TREE
),
3837 (! ffeste_io_abort_is_temp_
) || (end
!= FFECOM_gfrt
));
3840 /* WRITE statement -- I/O item. */
3843 ffeste_R910_item (ffebld expr
, ffelexToken expr_token
)
3845 ffeste_check_item_ ();
3850 if (ffebld_op (expr
) == FFEBLD_opANY
)
3853 if (ffebld_op (expr
) == FFEBLD_opIMPDO
)
3854 ffeste_io_impdo_ (expr
, expr_token
);
3857 ffeste_start_stmt_ ();
3859 ffecom_prepare_arg_ptr_to_expr (expr
);
3861 ffecom_prepare_end ();
3863 ffeste_io_call_ ((*ffeste_io_driver_
) (expr
), TRUE
);
3865 ffeste_end_stmt_ ();
3869 /* WRITE statement -- end. */
3872 ffeste_R910_finish (void)
3874 ffeste_check_finish_ ();
3876 /* Don't generate "if (iostat != 0) goto label;" if label is temp abort
3877 label, since we're gonna fall through to there anyway. */
3879 if (ffeste_io_endgfrt_
!= FFECOM_gfrt
)
3880 ffeste_io_call_ (ffecom_call_gfrt (ffeste_io_endgfrt_
, NULL_TREE
,
3882 ! ffeste_io_abort_is_temp_
);
3884 /* If we've got a temp label, generate its code here. */
3886 if (ffeste_io_abort_is_temp_
)
3888 DECL_INITIAL (ffeste_io_abort_
) = error_mark_node
;
3890 expand_label (ffeste_io_abort_
);
3892 assert (ffeste_io_err_
== NULL_TREE
);
3895 ffeste_end_stmt_ ();
3898 /* PRINT statement -- start. */
3901 ffeste_R911_start (ffestpPrintStmt
*info
, ffestvFormat format
)
3907 ffeste_check_start_ ();
3909 ffeste_emit_line_note_ ();
3911 /* First determine the start, per-item, and end run-time functions to
3912 call. The per-item function is picked by choosing an ffeste function
3913 to call to handle a given item; it knows how to generate a call to the
3914 appropriate run-time function, and is called an "I/O driver". */
3918 case FFESTV_formatLABEL
: /* FMT=10 */
3919 case FFESTV_formatCHAREXPR
: /* FMT='(I10)' */
3920 case FFESTV_formatINTEXPR
: /* FMT=I [after ASSIGN 10 TO I] */
3921 ffeste_io_driver_
= ffeste_io_dofio_
;
3922 start
= FFECOM_gfrtSWSFE
, end
= FFECOM_gfrtEWSFE
;
3925 case FFESTV_formatASTERISK
: /* FMT=* */
3926 ffeste_io_driver_
= ffeste_io_dolio_
;
3927 start
= FFECOM_gfrtSWSLE
, end
= FFECOM_gfrtEWSLE
;
3930 case FFESTV_formatNAMELIST
: /* FMT=FOO or NML=FOO [NAMELIST
3932 ffeste_io_driver_
= NULL
; /* No start or driver function. */
3933 start
= FFECOM_gfrtSWSNE
, end
= FFECOM_gfrt
;
3937 assert ("Weird stuff" == NULL
);
3938 start
= FFECOM_gfrt
, end
= FFECOM_gfrt
;
3941 ffeste_io_endgfrt_
= end
;
3943 ffeste_start_stmt_ ();
3945 ffeste_io_end_
= NULL_TREE
;
3946 ffeste_io_err_
= NULL_TREE
;
3947 ffeste_io_abort_
= NULL_TREE
;
3948 ffeste_io_abort_is_temp_
= FALSE
;
3949 ffeste_io_iostat_is_temp_
= FALSE
;
3950 ffeste_io_iostat_
= NULL_TREE
;
3952 /* Now prescan, then convert, all the arguments. */
3954 cilist
= ffeste_io_cilist_ (FALSE
, FFESTV_unitNONE
, NULL
, 6, FALSE
, format
,
3955 &info
->print_spec
[FFESTP_printixFORMAT
],
3958 /* If there is no end function, then there are no item functions (i.e.
3959 it's a NAMELIST), and vice versa by the way. In this situation, don't
3960 generate the "if (iostat != 0) goto label;" if the label is temp abort
3961 label, since we're gonna fall through to there anyway. */
3963 ffeste_io_call_ (ffecom_call_gfrt (start
, cilist
, NULL_TREE
),
3964 (! ffeste_io_abort_is_temp_
) || (end
!= FFECOM_gfrt
));
3967 /* PRINT statement -- I/O item. */
3970 ffeste_R911_item (ffebld expr
, ffelexToken expr_token
)
3972 ffeste_check_item_ ();
3977 if (ffebld_op (expr
) == FFEBLD_opANY
)
3980 if (ffebld_op (expr
) == FFEBLD_opIMPDO
)
3981 ffeste_io_impdo_ (expr
, expr_token
);
3984 ffeste_start_stmt_ ();
3986 ffecom_prepare_arg_ptr_to_expr (expr
);
3988 ffecom_prepare_end ();
3990 ffeste_io_call_ ((*ffeste_io_driver_
) (expr
), TRUE
);
3992 ffeste_end_stmt_ ();
3996 /* PRINT statement -- end. */
3999 ffeste_R911_finish (void)
4001 ffeste_check_finish_ ();
4003 if (ffeste_io_endgfrt_
!= FFECOM_gfrt
)
4004 ffeste_io_call_ (ffecom_call_gfrt (ffeste_io_endgfrt_
, NULL_TREE
,
4008 ffeste_end_stmt_ ();
4011 /* BACKSPACE statement. */
4014 ffeste_R919 (ffestpBeruStmt
*info
)
4016 ffeste_check_simple_ ();
4018 ffeste_subr_beru_ (info
, FFECOM_gfrtFBACK
);
4021 /* ENDFILE statement. */
4024 ffeste_R920 (ffestpBeruStmt
*info
)
4026 ffeste_check_simple_ ();
4028 ffeste_subr_beru_ (info
, FFECOM_gfrtFEND
);
4031 /* REWIND statement. */
4034 ffeste_R921 (ffestpBeruStmt
*info
)
4036 ffeste_check_simple_ ();
4038 ffeste_subr_beru_ (info
, FFECOM_gfrtFREW
);
4041 /* INQUIRE statement (non-IOLENGTH version). */
4044 ffeste_R923A (ffestpInquireStmt
*info
, bool by_file UNUSED
)
4050 ffeste_check_simple_ ();
4052 ffeste_emit_line_note_ ();
4054 #define specified(something) (info->inquire_spec[something].kw_or_val_present)
4056 iostat
= specified (FFESTP_inquireixIOSTAT
);
4057 errl
= specified (FFESTP_inquireixERR
);
4061 ffeste_start_stmt_ ();
4067 = ffecom_lookup_label
4068 (info
->inquire_spec
[FFESTP_inquireixERR
].u
.label
);
4069 ffeste_io_abort_is_temp_
= FALSE
;
4073 ffeste_io_err_
= NULL_TREE
;
4075 if ((ffeste_io_abort_is_temp_
= iostat
))
4076 ffeste_io_abort_
= ffecom_temp_label ();
4078 ffeste_io_abort_
= NULL_TREE
;
4083 /* Have IOSTAT= specification. */
4085 ffeste_io_iostat_is_temp_
= FALSE
;
4086 ffeste_io_iostat_
= ffecom_expr
4087 (info
->inquire_spec
[FFESTP_inquireixIOSTAT
].u
.expr
);
4089 else if (ffeste_io_abort_
!= NULL_TREE
)
4091 /* Have no IOSTAT= but have ERR=. */
4093 ffeste_io_iostat_is_temp_
= TRUE
;
4095 = ffecom_make_tempvar ("inquire", ffecom_integer_type_node
,
4096 FFETARGET_charactersizeNONE
, -1);
4100 /* No IOSTAT= or ERR= specification. */
4102 ffeste_io_iostat_is_temp_
= FALSE
;
4103 ffeste_io_iostat_
= NULL_TREE
;
4106 /* Now prescan, then convert, all the arguments. */
4109 = ffeste_io_inlist_ (errl
|| iostat
,
4110 &info
->inquire_spec
[FFESTP_inquireixUNIT
],
4111 &info
->inquire_spec
[FFESTP_inquireixFILE
],
4112 &info
->inquire_spec
[FFESTP_inquireixEXIST
],
4113 &info
->inquire_spec
[FFESTP_inquireixOPENED
],
4114 &info
->inquire_spec
[FFESTP_inquireixNUMBER
],
4115 &info
->inquire_spec
[FFESTP_inquireixNAMED
],
4116 &info
->inquire_spec
[FFESTP_inquireixNAME
],
4117 &info
->inquire_spec
[FFESTP_inquireixACCESS
],
4118 &info
->inquire_spec
[FFESTP_inquireixSEQUENTIAL
],
4119 &info
->inquire_spec
[FFESTP_inquireixDIRECT
],
4120 &info
->inquire_spec
[FFESTP_inquireixFORM
],
4121 &info
->inquire_spec
[FFESTP_inquireixFORMATTED
],
4122 &info
->inquire_spec
[FFESTP_inquireixUNFORMATTED
],
4123 &info
->inquire_spec
[FFESTP_inquireixRECL
],
4124 &info
->inquire_spec
[FFESTP_inquireixNEXTREC
],
4125 &info
->inquire_spec
[FFESTP_inquireixBLANK
]);
4127 /* Don't generate "if (iostat != 0) goto label;" if label is temp abort
4128 label, since we're gonna fall through to there anyway. */
4130 ffeste_io_call_ (ffecom_call_gfrt (FFECOM_gfrtFINQU
, args
, NULL_TREE
),
4131 ! ffeste_io_abort_is_temp_
);
4133 /* If we've got a temp label, generate its code here. */
4135 if (ffeste_io_abort_is_temp_
)
4137 DECL_INITIAL (ffeste_io_abort_
) = error_mark_node
;
4139 expand_label (ffeste_io_abort_
);
4141 assert (ffeste_io_err_
== NULL_TREE
);
4144 ffeste_end_stmt_ ();
4147 /* INQUIRE(IOLENGTH=expr) statement -- start. */
4150 ffeste_R923B_start (ffestpInquireStmt
*info UNUSED
)
4152 ffeste_check_start_ ();
4154 assert ("INQUIRE(IOLENGTH=<var>) not implemented yet! ~~~" == NULL
);
4156 ffeste_emit_line_note_ ();
4159 /* INQUIRE(IOLENGTH=expr) statement -- I/O item. */
4162 ffeste_R923B_item (ffebld expr UNUSED
)
4164 ffeste_check_item_ ();
4167 /* INQUIRE(IOLENGTH=expr) statement -- end. */
4170 ffeste_R923B_finish (void)
4172 ffeste_check_finish_ ();
4175 /* ffeste_R1001 -- FORMAT statement
4177 ffeste_R1001(format_list); */
4180 ffeste_R1001 (ffests s
)
4187 ffeste_check_simple_ ();
4189 assert (ffeste_label_formatdef_
!= NULL
);
4191 ffeste_emit_line_note_ ();
4193 t
= build_string (ffests_length (s
), ffests_text (s
));
4196 = build_type_variant (build_array_type
4198 build_range_type (integer_type_node
,
4200 build_int_2 (ffests_length (s
),
4203 TREE_CONSTANT (t
) = 1;
4204 TREE_STATIC (t
) = 1;
4206 var
= ffecom_lookup_label (ffeste_label_formatdef_
);
4207 if ((var
!= NULL_TREE
)
4208 && (TREE_CODE (var
) == VAR_DECL
))
4210 DECL_INITIAL (var
) = t
;
4211 maxindex
= build_int_2 (ffests_length (s
) - 1, 0);
4212 ttype
= TREE_TYPE (var
);
4213 TYPE_DOMAIN (ttype
) = build_range_type (integer_type_node
,
4216 if (!TREE_TYPE (maxindex
))
4217 TREE_TYPE (maxindex
) = TYPE_DOMAIN (ttype
);
4218 layout_type (ttype
);
4219 rest_of_decl_compilation (var
, NULL
, 1, 0);
4221 expand_decl_init (var
);
4224 ffeste_label_formatdef_
= NULL
;
4234 /* END BLOCK DATA. */
4241 /* CALL statement. */
4244 ffeste_R1212 (ffebld expr
)
4248 ffebld labels
= NULL
; /* First in list of LABTERs. */
4249 ffebld prevlabels
= NULL
;
4250 ffebld prevargs
= NULL
;
4252 ffeste_check_simple_ ();
4254 args
= ffebld_right (expr
);
4256 ffeste_emit_line_note_ ();
4258 /* Here we split the list at ffebld_right(expr) into two lists: one at
4259 ffebld_right(expr) consisting of all items that are not LABTERs, the
4260 other at labels consisting of all items that are LABTERs. Then, if
4261 the latter list is NULL, we have an ordinary call, else we have a call
4262 with alternate returns. */
4264 for (args
= ffebld_right (expr
); args
!= NULL
; args
= ffebld_trail (args
))
4266 if (((arg
= ffebld_head (args
)) == NULL
)
4267 || (ffebld_op (arg
) != FFEBLD_opLABTER
))
4269 if (prevargs
== NULL
)
4272 ffebld_set_right (expr
, args
);
4276 ffebld_set_trail (prevargs
, args
);
4282 if (prevlabels
== NULL
)
4284 prevlabels
= labels
= args
;
4288 ffebld_set_trail (prevlabels
, args
);
4293 if (prevlabels
== NULL
)
4296 ffebld_set_trail (prevlabels
, NULL
);
4297 if (prevargs
== NULL
)
4298 ffebld_set_right (expr
, NULL
);
4300 ffebld_set_trail (prevargs
, NULL
);
4302 ffeste_start_stmt_ ();
4304 /* No temporaries are actually needed at this level, but we go
4305 through the motions anyway, just to be sure in case they do
4306 get made. Temporaries needed for arguments should be in the
4307 scopes of inner blocks, and if clean-up actions are supported,
4308 such as CALL-ing an intrinsic that writes to an argument of one
4309 type when a variable of a different type is provided (requiring
4310 assignment to the variable from a temporary after the library
4311 routine returns), the clean-up must be done by the expression
4312 evaluator, generally, to handle alternate returns (which we hope
4313 won't ever be supported by intrinsics, but might be a similar
4314 issue, such as CALL-ing an F90-style subroutine with an INTERFACE
4315 block). That implies the expression evaluator will have to
4316 recognize the need for its own temporary anyway, meaning it'll
4317 construct a block within the one constructed here. */
4319 ffecom_prepare_expr (expr
);
4321 ffecom_prepare_end ();
4324 expand_expr_stmt (ffecom_expr (expr
));
4335 texpr
= ffecom_expr (expr
);
4336 expand_start_case (0, texpr
, TREE_TYPE (texpr
), "CALL statement");
4338 for (caseno
= 1, label
= labels
;
4340 ++caseno
, label
= ffebld_trail (label
))
4342 value
= build_int_2 (caseno
, 0);
4343 tlabel
= build_decl (LABEL_DECL
, NULL_TREE
, NULL_TREE
);
4345 pushok
= pushcase (value
, convert
, tlabel
, &duplicate
);
4346 assert (pushok
== 0);
4349 = ffecom_lookup_label (ffebld_labter (ffebld_head (label
)));
4350 if ((tlabel
== NULL_TREE
)
4351 || (TREE_CODE (tlabel
) == ERROR_MARK
))
4353 TREE_USED (tlabel
) = 1;
4354 expand_goto (tlabel
);
4357 expand_end_case (texpr
);
4360 ffeste_end_stmt_ ();
4370 /* END SUBROUTINE. */
4377 /* ENTRY statement. */
4380 ffeste_R1226 (ffesymbol entry
)
4384 ffeste_check_simple_ ();
4386 label
= ffesymbol_hook (entry
).length_tree
;
4388 ffeste_emit_line_note_ ();
4390 if (label
== error_mark_node
)
4393 DECL_INITIAL (label
) = error_mark_node
;
4395 expand_label (label
);
4398 /* RETURN statement. */
4401 ffeste_R1227 (ffestw block UNUSED
, ffebld expr
)
4405 ffeste_check_simple_ ();
4407 ffeste_emit_line_note_ ();
4409 ffeste_start_stmt_ ();
4411 ffecom_prepare_return_expr (expr
);
4413 ffecom_prepare_end ();
4415 rtn
= ffecom_return_expr (expr
);
4417 if ((rtn
== NULL_TREE
)
4418 || (rtn
== error_mark_node
))
4419 expand_null_return ();
4422 tree result
= DECL_RESULT (current_function_decl
);
4424 if ((result
!= error_mark_node
)
4425 && (TREE_TYPE (result
) != error_mark_node
))
4426 expand_return (ffecom_modify (NULL_TREE
,
4428 convert (TREE_TYPE (result
),
4431 expand_null_return ();
4434 ffeste_end_stmt_ ();
4437 /* REWRITE statement -- start. */
4439 /* TYPE statement -- start. */
4442 ffeste_V020_start (ffestpTypeStmt
*info UNUSED
,
4443 ffestvFormat format UNUSED
)
4445 ffeste_check_start_ ();
4448 /* TYPE statement -- I/O item. */
4451 ffeste_V020_item (ffebld expr UNUSED
)
4453 ffeste_check_item_ ();
4456 /* TYPE statement -- end. */
4459 ffeste_V020_finish (void)
4461 ffeste_check_finish_ ();
4464 /* DELETE statement. */
4467 #ifdef ENABLE_CHECKING
4469 ffeste_terminate_2 (void)
4471 assert (! ffeste_top_block_
);
4475 #include "gt-f-ste.h"