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, lineno)
145 #define ffeste_check_simple_() \
146 assert(ffeste_statelet_ == FFESTE_stateletSIMPLE_)
147 #define ffeste_check_start_() \
148 assert(ffeste_statelet_ == FFESTE_stateletSIMPLE_); \
149 ffeste_statelet_ = FFESTE_stateletATTRIB_
150 #define ffeste_check_attrib_() \
151 assert(ffeste_statelet_ == FFESTE_stateletATTRIB_)
152 #define ffeste_check_item_() \
153 assert(ffeste_statelet_ == FFESTE_stateletATTRIB_ \
154 || ffeste_statelet_ == FFESTE_stateletITEM_); \
155 ffeste_statelet_ = FFESTE_stateletITEM_
156 #define ffeste_check_item_startvals_() \
157 assert(ffeste_statelet_ == FFESTE_stateletATTRIB_ \
158 || ffeste_statelet_ == FFESTE_stateletITEM_); \
159 ffeste_statelet_ = FFESTE_stateletITEMVALS_
160 #define ffeste_check_item_value_() \
161 assert(ffeste_statelet_ == FFESTE_stateletITEMVALS_)
162 #define ffeste_check_item_endvals_() \
163 assert(ffeste_statelet_ == FFESTE_stateletITEMVALS_); \
164 ffeste_statelet_ = FFESTE_stateletITEM_
165 #define ffeste_check_finish_() \
166 assert(ffeste_statelet_ == FFESTE_stateletATTRIB_ \
167 || ffeste_statelet_ == FFESTE_stateletITEM_); \
168 ffeste_statelet_ = FFESTE_stateletSIMPLE_
170 #define ffeste_f2c_init_charnolen_(Exp,Init,Spec) \
173 if ((Spec)->kw_or_val_present) \
174 Exp = ffecom_arg_ptr_to_const_expr ((Spec)->u.expr, &ignore); \
176 Exp = null_pointer_node; \
181 Init = null_pointer_node; \
186 #define ffeste_f2c_init_char_(Exp,Init,Lenexp,Leninit,Spec) \
189 if ((Spec)->kw_or_val_present) \
190 Exp = ffecom_arg_ptr_to_const_expr ((Spec)->u.expr, &Lenexp); \
193 Exp = null_pointer_node; \
194 Lenexp = ffecom_f2c_ftnlen_zero_node; \
200 Init = null_pointer_node; \
207 Leninit = ffecom_f2c_ftnlen_zero_node; \
212 #define ffeste_f2c_init_flag_(Flag,Init) \
215 Init = convert (ffecom_f2c_flag_type_node, \
216 (Flag) ? integer_one_node : integer_zero_node); \
219 #define ffeste_f2c_init_format_(Exp,Init,Spec) \
222 Exp = ffecom_arg_ptr_to_const_expr ((Spec)->u.expr, NULL); \
227 Init = null_pointer_node; \
232 #define ffeste_f2c_init_int_(Exp,Init,Spec) \
235 if ((Spec)->kw_or_val_present) \
236 Exp = ffecom_const_expr ((Spec)->u.expr); \
238 Exp = ffecom_integer_zero_node; \
243 Init = ffecom_integer_zero_node; \
248 #define ffeste_f2c_init_ptrtoint_(Exp,Init,Spec) \
251 if ((Spec)->kw_or_val_present) \
252 Exp = ffecom_ptr_to_const_expr ((Spec)->u.expr); \
254 Exp = null_pointer_node; \
259 Init = null_pointer_node; \
264 #define ffeste_f2c_init_next_(Init) \
267 TREE_CHAIN (initn) = build_tree_list ((field = TREE_CHAIN (field)), \
269 initn = TREE_CHAIN(initn); \
272 #define ffeste_f2c_prepare_charnolen_(Spec,Exp) \
276 ffecom_prepare_arg_ptr_to_expr ((Spec)->u.expr); \
279 #define ffeste_f2c_prepare_char_(Spec,Exp) \
283 ffecom_prepare_arg_ptr_to_expr ((Spec)->u.expr); \
286 #define ffeste_f2c_prepare_format_(Spec,Exp) \
290 ffecom_prepare_arg_ptr_to_expr ((Spec)->u.expr); \
293 #define ffeste_f2c_prepare_int_(Spec,Exp) \
297 ffecom_prepare_expr ((Spec)->u.expr); \
300 #define ffeste_f2c_prepare_ptrtoint_(Spec,Exp) \
304 ffecom_prepare_ptr_to_expr ((Spec)->u.expr); \
307 #define ffeste_f2c_compile_(Field,Exp) \
313 exz = ffecom_modify (void_type_node, \
314 ffecom_2 (COMPONENT_REF, TREE_TYPE (Field), \
317 expand_expr_stmt (exz); \
321 #define ffeste_f2c_compile_charnolen_(Field,Spec,Exp) \
327 exq = ffecom_arg_ptr_to_expr ((Spec)->u.expr, &ignore); \
328 ffeste_f2c_compile_ ((Field), exq); \
332 #define ffeste_f2c_compile_char_(Field,Lenfield,Spec,Exp,Lenexp) \
336 tree lenexq = (Lenexp); \
337 int need_exq = (! exq); \
338 int need_lenexq = (! lenexq); \
339 if (need_exq || need_lenexq) \
341 exq = ffecom_arg_ptr_to_expr ((Spec)->u.expr, &lenexq); \
343 ffeste_f2c_compile_ ((Field), exq); \
345 ffeste_f2c_compile_ ((Lenfield), lenexq); \
349 #define ffeste_f2c_compile_format_(Field,Spec,Exp) \
355 exq = ffecom_arg_ptr_to_expr ((Spec)->u.expr, NULL); \
356 ffeste_f2c_compile_ ((Field), exq); \
360 #define ffeste_f2c_compile_int_(Field,Spec,Exp) \
366 exq = ffecom_expr ((Spec)->u.expr); \
367 ffeste_f2c_compile_ ((Field), exq); \
371 #define ffeste_f2c_compile_ptrtoint_(Field,Spec,Exp) \
377 exq = ffecom_ptr_to_expr ((Spec)->u.expr); \
378 ffeste_f2c_compile_ ((Field), exq); \
382 /* Start a Fortran block. */
384 #ifdef ENABLE_CHECKING
386 typedef struct gbe_block
388 struct gbe_block
*outer
;
391 const char *input_filename
;
395 gbe_block ffeste_top_block_
= NULL
;
398 ffeste_start_block_ (ffestw block
)
400 gbe_block b
= xmalloc (sizeof (*b
));
402 b
->outer
= ffeste_top_block_
;
405 b
->input_filename
= input_filename
;
408 ffeste_top_block_
= b
;
410 ffecom_start_compstmt ();
413 /* End a Fortran block. */
416 ffeste_end_block_ (ffestw block
)
418 gbe_block b
= ffeste_top_block_
;
421 assert (! b
->is_stmt
);
422 assert (b
->block
== block
);
423 assert (! b
->is_stmt
);
425 ffeste_top_block_
= b
->outer
;
429 ffecom_end_compstmt ();
432 /* Start a Fortran statement.
434 Starts a back-end block, so temporaries can be managed, clean-ups
435 properly handled, etc. Nesting of statements *is* allowed -- the
436 handling of I/O items, even implied-DO I/O lists, within a READ,
437 PRINT, or WRITE statement is one example. */
440 ffeste_start_stmt_(void)
442 gbe_block b
= xmalloc (sizeof (*b
));
444 b
->outer
= ffeste_top_block_
;
447 b
->input_filename
= input_filename
;
450 ffeste_top_block_
= b
;
452 ffecom_start_compstmt ();
455 /* End a Fortran statement. */
458 ffeste_end_stmt_(void)
460 gbe_block b
= ffeste_top_block_
;
465 ffeste_top_block_
= b
->outer
;
469 ffecom_end_compstmt ();
472 #else /* ! defined (ENABLE_CHECKING) */
474 #define ffeste_start_block_(b) ffecom_start_compstmt ()
475 #define ffeste_end_block_(b) \
478 ffecom_end_compstmt (); \
480 #define ffeste_start_stmt_() ffeste_start_block_(NULL)
481 #define ffeste_end_stmt_() ffeste_end_block_(NULL)
483 #endif /* ! defined (ENABLE_CHECKING) */
485 /* Begin an iterative DO loop. Pass the block to start if
489 ffeste_begin_iterdo_ (ffestw block
, tree
*xtvar
, tree
*xtincr
,
490 tree
*xitersvar
, ffebld var
,
491 ffebld start
, ffelexToken start_token
,
492 ffebld end
, ffelexToken end_token
,
493 ffebld incr
, ffelexToken incr_token
,
503 struct nesting
*expanded_loop
;
505 /* Want to have tvar, tincr, and niters for the whole loop body. */
508 ffeste_start_block_ (block
);
510 ffeste_start_stmt_ ();
512 niters
= ffecom_make_tempvar (block
? "do" : "impdo",
513 ffecom_integer_type_node
,
514 FFETARGET_charactersizeNONE
, -1);
516 ffecom_prepare_expr (incr
);
517 ffecom_prepare_expr_rw (NULL_TREE
, var
);
519 ffecom_prepare_end ();
521 tvar
= ffecom_expr_rw (NULL_TREE
, var
);
522 tincr
= ffecom_expr (incr
);
524 if (TREE_CODE (tvar
) == ERROR_MARK
525 || TREE_CODE (tincr
) == ERROR_MARK
)
529 ffeste_end_block_ (block
);
530 ffestw_set_do_tvar (block
, error_mark_node
);
535 *xtvar
= error_mark_node
;
540 /* Check whether incr is known to be zero, complain and fix. */
542 if (integer_zerop (tincr
) || real_zerop (tincr
))
544 ffebad_start (FFEBAD_DO_STEP_ZERO
);
545 ffebad_here (0, ffelex_token_where_line (incr_token
),
546 ffelex_token_where_column (incr_token
));
549 tincr
= convert (TREE_TYPE (tvar
), integer_one_node
);
552 tincr_saved
= ffecom_save_tree (tincr
);
554 /* Want to have tstart, tend for just this statement. */
556 ffeste_start_stmt_ ();
558 ffecom_prepare_expr (start
);
559 ffecom_prepare_expr (end
);
561 ffecom_prepare_end ();
563 tstart
= ffecom_expr (start
);
564 tend
= ffecom_expr (end
);
566 if (TREE_CODE (tstart
) == ERROR_MARK
567 || TREE_CODE (tend
) == ERROR_MARK
)
573 ffeste_end_block_ (block
);
574 ffestw_set_do_tvar (block
, error_mark_node
);
579 *xtvar
= error_mark_node
;
584 /* For warnings only, nothing else happens here. */
588 if (! ffe_is_onetrip ())
590 try = ffecom_2 (MINUS_EXPR
, TREE_TYPE (tvar
),
594 try = ffecom_2 (PLUS_EXPR
, TREE_TYPE (tvar
),
598 if (TREE_CODE (TREE_TYPE (tvar
)) != REAL_TYPE
)
599 try = ffecom_2 (TRUNC_DIV_EXPR
, integer_type_node
, try,
602 try = convert (integer_type_node
,
603 ffecom_2 (RDIV_EXPR
, TREE_TYPE (tvar
),
607 /* Warn if loop never executed, since we've done the evaluation
608 of the unofficial iteration count already. */
610 try = ffecom_truth_value (ffecom_2 (LE_EXPR
, integer_type_node
,
612 convert (TREE_TYPE (tvar
),
613 integer_zero_node
)));
615 if (integer_onep (try))
617 ffebad_start (FFEBAD_DO_NULL
);
618 ffebad_here (0, ffelex_token_where_line (start_token
),
619 ffelex_token_where_column (start_token
));
625 /* Warn if end plus incr would overflow. */
627 try = ffecom_2 (PLUS_EXPR
, TREE_TYPE (tvar
),
631 if ((TREE_CODE_CLASS (TREE_CODE (try)) == 'c')
632 && TREE_CONSTANT_OVERFLOW (try))
634 ffebad_start (FFEBAD_DO_END_OVERFLOW
);
635 ffebad_here (0, ffelex_token_where_line (end_token
),
636 ffelex_token_where_column (end_token
));
642 /* Do the initial assignment into the DO var. */
644 tstart
= ffecom_save_tree (tstart
);
646 expr
= ffecom_2 (MINUS_EXPR
, TREE_TYPE (tvar
),
650 if (! ffe_is_onetrip ())
652 expr
= ffecom_2 (PLUS_EXPR
, TREE_TYPE (expr
),
654 convert (TREE_TYPE (expr
), tincr_saved
));
657 if (TREE_CODE (TREE_TYPE (tvar
)) != REAL_TYPE
)
658 expr
= ffecom_2 (TRUNC_DIV_EXPR
, TREE_TYPE (expr
),
662 expr
= ffecom_2 (RDIV_EXPR
, TREE_TYPE (expr
),
666 #if 1 /* New, F90-approved approach: convert to default INTEGER. */
667 if (TREE_TYPE (tvar
) != error_mark_node
)
668 expr
= convert (ffecom_integer_type_node
, expr
);
669 #else /* Old approach; convert to INTEGER unless that's a narrowing. */
670 if ((TREE_TYPE (tvar
) != error_mark_node
)
671 && ((TREE_CODE (TREE_TYPE (tvar
)) != INTEGER_TYPE
)
672 || ((TYPE_SIZE (TREE_TYPE (tvar
)) != NULL_TREE
)
673 && ((TREE_CODE (TYPE_SIZE (TREE_TYPE (tvar
)))
675 || (TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (tvar
)))
676 <= TREE_INT_CST_LOW (TYPE_SIZE (ffecom_integer_type_node
)))))))
677 /* Convert unless promoting INTEGER type of any kind downward to
678 default INTEGER; else leave as, say, INTEGER*8 (long long int). */
679 expr
= convert (ffecom_integer_type_node
, expr
);
682 assert (TYPE_MAIN_VARIANT (TREE_TYPE (niters
))
683 == TYPE_MAIN_VARIANT (TREE_TYPE (expr
)));
685 expr
= ffecom_modify (void_type_node
, niters
, expr
);
686 expand_expr_stmt (expr
);
688 expr
= ffecom_modify (void_type_node
, tvar
, tstart
);
689 expand_expr_stmt (expr
);
693 expanded_loop
= expand_start_loop_continue_elsewhere (!! block
);
695 ffestw_set_do_hook (block
, expanded_loop
);
697 if (! ffe_is_onetrip ())
699 expr
= ffecom_truth_value
700 (ffecom_2 (GE_EXPR
, integer_type_node
,
701 ffecom_2 (PREDECREMENT_EXPR
,
704 convert (TREE_TYPE (niters
),
705 ffecom_integer_one_node
)),
706 convert (TREE_TYPE (niters
),
707 ffecom_integer_zero_node
)));
709 expand_exit_loop_top_cond (0, expr
);
714 ffestw_set_do_tvar (block
, tvar
);
715 ffestw_set_do_incr_saved (block
, tincr_saved
);
716 ffestw_set_do_count_var (block
, niters
);
721 *xtincr
= tincr_saved
;
726 /* End an iterative DO loop. Pass the same iteration variable and increment
727 value trees that were generated in the paired _begin_ call. */
730 ffeste_end_iterdo_ (ffestw block
, tree tvar
, tree tincr
, tree itersvar
)
733 tree niters
= itersvar
;
735 if (tvar
== error_mark_node
)
738 expand_loop_continue_here ();
740 ffeste_start_stmt_ ();
742 if (ffe_is_onetrip ())
744 expr
= ffecom_truth_value
745 (ffecom_2 (GE_EXPR
, integer_type_node
,
746 ffecom_2 (PREDECREMENT_EXPR
,
749 convert (TREE_TYPE (niters
),
750 ffecom_integer_one_node
)),
751 convert (TREE_TYPE (niters
),
752 ffecom_integer_zero_node
)));
754 expand_exit_loop_if_false (0, expr
);
757 expr
= ffecom_modify (void_type_node
, tvar
,
758 ffecom_2 (PLUS_EXPR
, TREE_TYPE (tvar
),
761 expand_expr_stmt (expr
);
763 /* Lose the stuff we just built. */
768 /* Lose the tvar and incr_saved trees. */
770 ffeste_end_block_ (block
);
775 /* Generate call to run-time I/O routine. */
778 ffeste_io_call_ (tree call
, bool do_check
)
780 /* Generate the call and optional assignment into iostat var. */
782 TREE_SIDE_EFFECTS (call
) = 1;
783 if (ffeste_io_iostat_
!= NULL_TREE
)
784 call
= ffecom_modify (do_check
? NULL_TREE
: void_type_node
,
785 ffeste_io_iostat_
, call
);
786 expand_expr_stmt (call
);
789 || ffeste_io_abort_
== NULL_TREE
790 || TREE_CODE (ffeste_io_abort_
) == ERROR_MARK
)
793 /* Generate optional test. */
795 expand_start_cond (ffecom_truth_value (ffeste_io_iostat_
), 0);
796 expand_goto (ffeste_io_abort_
);
800 /* Handle implied-DO in I/O list.
802 Expands code to start up the DO loop. Then for each item in the
803 DO loop, handles appropriately (possibly including recursively calling
804 itself). Then expands code to end the DO loop. */
807 ffeste_io_impdo_ (ffebld impdo
, ffelexToken impdo_token
)
809 ffebld var
= ffebld_head (ffebld_right (impdo
));
810 ffebld start
= ffebld_head (ffebld_trail (ffebld_right (impdo
)));
811 ffebld end
= ffebld_head (ffebld_trail (ffebld_trail
812 (ffebld_right (impdo
))));
813 ffebld incr
= ffebld_head (ffebld_trail (ffebld_trail
814 (ffebld_trail (ffebld_right (impdo
)))));
823 incr
= ffebld_new_conter (ffebld_constant_new_integerdefault_val (1));
824 ffebld_set_info (incr
, ffeinfo_new
825 (FFEINFO_basictypeINTEGER
,
826 FFEINFO_kindtypeINTEGERDEFAULT
,
829 FFEINFO_whereCONSTANT
,
830 FFETARGET_charactersizeNONE
));
833 /* Start the DO loop. */
835 start
= ffeexpr_convert_expr (start
, impdo_token
, var
, impdo_token
,
837 end
= ffeexpr_convert_expr (end
, impdo_token
, var
, impdo_token
,
839 incr
= ffeexpr_convert_expr (incr
, impdo_token
, var
, impdo_token
,
842 ffeste_begin_iterdo_ (NULL
, &tvar
, &tincr
, &titervar
, var
,
848 /* Handle the list of items. */
850 for (list
= ffebld_left (impdo
); list
!= NULL
; list
= ffebld_trail (list
))
852 item
= ffebld_head (list
);
856 /* Strip parens off items such as in "READ *,(A)". This is really a bug
857 in the user's code, but I've been told lots of code does this. */
858 while (ffebld_op (item
) == FFEBLD_opPAREN
)
859 item
= ffebld_left (item
);
861 if (ffebld_op (item
) == FFEBLD_opANY
)
864 if (ffebld_op (item
) == FFEBLD_opIMPDO
)
865 ffeste_io_impdo_ (item
, impdo_token
);
868 ffeste_start_stmt_ ();
870 ffecom_prepare_arg_ptr_to_expr (item
);
872 ffecom_prepare_end ();
874 ffeste_io_call_ ((*ffeste_io_driver_
) (item
), TRUE
);
880 /* Generate end of implied-do construct. */
882 ffeste_end_iterdo_ (NULL
, tvar
, tincr
, titervar
);
885 /* I/O driver for formatted I/O item (do_fio)
887 Returns a tree for a CALL_EXPR to the do_fio function, which handles
888 a formatted I/O list item, along with the appropriate arguments for
889 the function. It is up to the caller to set the TREE_SIDE_EFFECTS flag
890 for the CALL_EXPR, expand (emit) the expression, emit any assignment
891 of the result to an IOSTAT= variable, and emit any checking of the
892 result for errors. */
895 ffeste_io_dofio_ (ffebld expr
)
905 bt
= ffeinfo_basictype (ffebld_info (expr
));
906 kt
= ffeinfo_kindtype (ffebld_info (expr
));
908 if ((bt
== FFEINFO_basictypeANY
)
909 || (kt
== FFEINFO_kindtypeANY
))
910 return error_mark_node
;
912 if (bt
== FFEINFO_basictypeCOMPLEX
)
915 bt
= FFEINFO_basictypeREAL
;
920 variable
= ffecom_arg_ptr_to_expr (expr
, &size
);
922 if ((variable
== error_mark_node
)
923 || (size
== error_mark_node
))
924 return error_mark_node
;
926 if (size
== NULL_TREE
) /* Already filled in for CHARACTER type. */
927 { /* "(ftnlen) sizeof(type)" */
928 size
= size_binop (CEIL_DIV_EXPR
,
929 TYPE_SIZE_UNIT (ffecom_tree_type
[bt
][kt
]),
930 size_int (TYPE_PRECISION (char_type_node
)
932 #if 0 /* Assume that while it is possible that char * is wider than
933 ftnlen, no object in Fortran space can get big enough for its
934 size to be wider than ftnlen. I really hope nobody wastes
935 time debugging a case where it can! */
936 assert (TYPE_PRECISION (ffecom_f2c_ftnlen_type_node
)
937 >= TYPE_PRECISION (TREE_TYPE (size
)));
939 size
= convert (ffecom_f2c_ftnlen_type_node
, size
);
942 if (ffeinfo_rank (ffebld_info (expr
)) == 0
943 || TREE_CODE (TREE_TYPE (TREE_TYPE (variable
))) != ARRAY_TYPE
)
945 = is_complex
? ffecom_f2c_ftnlen_two_node
: ffecom_f2c_ftnlen_one_node
;
949 = size_binop (CEIL_DIV_EXPR
,
950 TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (variable
))),
951 convert (sizetype
, size
));
952 num_elements
= size_binop (CEIL_DIV_EXPR
, num_elements
,
953 size_int (TYPE_PRECISION (char_type_node
)
955 num_elements
= convert (ffecom_f2c_ftnlen_type_node
,
960 = ffecom_1 (ADDR_EXPR
, ffecom_f2c_ptr_to_ftnlen_type_node
,
963 variable
= convert (string_type_node
, variable
);
965 arglist
= build_tree_list (NULL_TREE
, num_elements
);
966 TREE_CHAIN (arglist
) = build_tree_list (NULL_TREE
, variable
);
967 TREE_CHAIN (TREE_CHAIN (arglist
)) = build_tree_list (NULL_TREE
, size
);
969 return ffecom_call_gfrt (FFECOM_gfrtDOFIO
, arglist
, NULL_TREE
);
972 /* I/O driver for list-directed I/O item (do_lio)
974 Returns a tree for a CALL_EXPR to the do_lio function, which handles
975 a list-directed I/O list item, along with the appropriate arguments for
976 the function. It is up to the caller to set the TREE_SIDE_EFFECTS flag
977 for the CALL_EXPR, expand (emit) the expression, emit any assignment
978 of the result to an IOSTAT= variable, and emit any checking of the
979 result for errors. */
982 ffeste_io_dolio_ (ffebld expr
)
993 bt
= ffeinfo_basictype (ffebld_info (expr
));
994 kt
= ffeinfo_kindtype (ffebld_info (expr
));
996 if ((bt
== FFEINFO_basictypeANY
)
997 || (kt
== FFEINFO_kindtypeANY
))
998 return error_mark_node
;
1000 tc
= ffecom_f2c_typecode (bt
, kt
);
1002 type_id
= build_int_2 (tc
, 0);
1005 = ffecom_1 (ADDR_EXPR
, ffecom_f2c_ptr_to_ftnint_type_node
,
1006 convert (ffecom_f2c_ftnint_type_node
,
1009 variable
= ffecom_arg_ptr_to_expr (expr
, &size
);
1011 if ((type_id
== error_mark_node
)
1012 || (variable
== error_mark_node
)
1013 || (size
== error_mark_node
))
1014 return error_mark_node
;
1016 if (size
== NULL_TREE
) /* Already filled in for CHARACTER type. */
1017 { /* "(ftnlen) sizeof(type)" */
1018 size
= size_binop (CEIL_DIV_EXPR
,
1019 TYPE_SIZE_UNIT (ffecom_tree_type
[bt
][kt
]),
1020 size_int (TYPE_PRECISION (char_type_node
)
1022 #if 0 /* Assume that while it is possible that char * is wider than
1023 ftnlen, no object in Fortran space can get big enough for its
1024 size to be wider than ftnlen. I really hope nobody wastes
1025 time debugging a case where it can! */
1026 assert (TYPE_PRECISION (ffecom_f2c_ftnlen_type_node
)
1027 >= TYPE_PRECISION (TREE_TYPE (size
)));
1029 size
= convert (ffecom_f2c_ftnlen_type_node
, size
);
1032 if (ffeinfo_rank (ffebld_info (expr
)) == 0
1033 || TREE_CODE (TREE_TYPE (TREE_TYPE (variable
))) != ARRAY_TYPE
)
1034 num_elements
= ffecom_integer_one_node
;
1038 = size_binop (CEIL_DIV_EXPR
,
1039 TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (variable
))),
1040 convert (sizetype
, size
));
1041 num_elements
= size_binop (CEIL_DIV_EXPR
, num_elements
,
1042 size_int (TYPE_PRECISION (char_type_node
)
1044 num_elements
= convert (ffecom_f2c_ftnlen_type_node
,
1049 = ffecom_1 (ADDR_EXPR
, ffecom_f2c_ptr_to_ftnlen_type_node
,
1052 variable
= convert (string_type_node
, variable
);
1054 arglist
= build_tree_list (NULL_TREE
, type_id
);
1055 TREE_CHAIN (arglist
) = build_tree_list (NULL_TREE
, num_elements
);
1056 TREE_CHAIN (TREE_CHAIN (arglist
)) = build_tree_list (NULL_TREE
, variable
);
1057 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (arglist
)))
1058 = build_tree_list (NULL_TREE
, size
);
1060 return ffecom_call_gfrt (FFECOM_gfrtDOLIO
, arglist
, NULL_TREE
);
1063 /* I/O driver for unformatted I/O item (do_uio)
1065 Returns a tree for a CALL_EXPR to the do_uio function, which handles
1066 an unformatted I/O list item, along with the appropriate arguments for
1067 the function. It is up to the caller to set the TREE_SIDE_EFFECTS flag
1068 for the CALL_EXPR, expand (emit) the expression, emit any assignment
1069 of the result to an IOSTAT= variable, and emit any checking of the
1070 result for errors. */
1073 ffeste_io_douio_ (ffebld expr
)
1079 ffeinfoBasictype bt
;
1083 bt
= ffeinfo_basictype (ffebld_info (expr
));
1084 kt
= ffeinfo_kindtype (ffebld_info (expr
));
1086 if ((bt
== FFEINFO_basictypeANY
)
1087 || (kt
== FFEINFO_kindtypeANY
))
1088 return error_mark_node
;
1090 if (bt
== FFEINFO_basictypeCOMPLEX
)
1093 bt
= FFEINFO_basictypeREAL
;
1098 variable
= ffecom_arg_ptr_to_expr (expr
, &size
);
1100 if ((variable
== error_mark_node
)
1101 || (size
== error_mark_node
))
1102 return error_mark_node
;
1104 if (size
== NULL_TREE
) /* Already filled in for CHARACTER type. */
1105 { /* "(ftnlen) sizeof(type)" */
1106 size
= size_binop (CEIL_DIV_EXPR
,
1107 TYPE_SIZE_UNIT (ffecom_tree_type
[bt
][kt
]),
1108 size_int (TYPE_PRECISION (char_type_node
)
1110 #if 0 /* Assume that while it is possible that char * is wider than
1111 ftnlen, no object in Fortran space can get big enough for its
1112 size to be wider than ftnlen. I really hope nobody wastes
1113 time debugging a case where it can! */
1114 assert (TYPE_PRECISION (ffecom_f2c_ftnlen_type_node
)
1115 >= TYPE_PRECISION (TREE_TYPE (size
)));
1117 size
= convert (ffecom_f2c_ftnlen_type_node
, size
);
1120 if (ffeinfo_rank (ffebld_info (expr
)) == 0
1121 || TREE_CODE (TREE_TYPE (TREE_TYPE (variable
))) != ARRAY_TYPE
)
1123 = is_complex
? ffecom_f2c_ftnlen_two_node
: ffecom_f2c_ftnlen_one_node
;
1127 = size_binop (CEIL_DIV_EXPR
,
1128 TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (variable
))),
1129 convert (sizetype
, size
));
1130 num_elements
= size_binop (CEIL_DIV_EXPR
, num_elements
,
1131 size_int (TYPE_PRECISION (char_type_node
)
1133 num_elements
= convert (ffecom_f2c_ftnlen_type_node
,
1138 = ffecom_1 (ADDR_EXPR
, ffecom_f2c_ptr_to_ftnlen_type_node
,
1141 variable
= convert (string_type_node
, variable
);
1143 arglist
= build_tree_list (NULL_TREE
, num_elements
);
1144 TREE_CHAIN (arglist
) = build_tree_list (NULL_TREE
, variable
);
1145 TREE_CHAIN (TREE_CHAIN (arglist
)) = build_tree_list (NULL_TREE
, size
);
1147 return ffecom_call_gfrt (FFECOM_gfrtDOUIO
, arglist
, NULL_TREE
);
1150 /* Make arglist with ptr to BACKSPACE/ENDFILE/REWIND control list.
1152 Returns a tree suitable as an argument list containing a pointer to
1153 a BACKSPACE/ENDFILE/REWIND control list. First, generates that control
1154 list, if necessary, along with any static and run-time initializations
1155 that are needed as specified by the arguments to this function.
1157 Must ensure that all expressions are prepared before being evaluated,
1158 for any whose evaluation might result in the generation of temporaries.
1160 Note that this means this function causes a transition, within the
1161 current block being code-generated via the back end, from the
1162 declaration of variables (temporaries) to the expanding of expressions,
1165 static GTY(()) tree f2c_alist_struct
;
1167 ffeste_io_ialist_ (bool have_err
,
1176 bool constantp
= TRUE
;
1177 static tree errfield
, unitfield
;
1178 tree errinit
, unitinit
;
1180 static int mynumber
= 0;
1182 if (f2c_alist_struct
== NULL_TREE
)
1186 ref
= make_node (RECORD_TYPE
);
1188 errfield
= ffecom_decl_field (ref
, NULL_TREE
, "err",
1189 ffecom_f2c_flag_type_node
);
1190 unitfield
= ffecom_decl_field (ref
, errfield
, "unit",
1191 ffecom_f2c_ftnint_type_node
);
1193 TYPE_FIELDS (ref
) = errfield
;
1196 f2c_alist_struct
= ref
;
1199 /* Try to do as much compile-time initialization of the structure
1200 as possible, to save run time. */
1202 ffeste_f2c_init_flag_ (have_err
, errinit
);
1206 case FFESTV_unitNONE
:
1207 case FFESTV_unitASTERISK
:
1208 unitinit
= build_int_2 (unit_dflt
, 0);
1212 case FFESTV_unitINTEXPR
:
1213 unitexp
= ffecom_const_expr (unit_expr
);
1218 unitinit
= ffecom_integer_zero_node
;
1224 assert ("bad unit spec" == NULL
);
1225 unitinit
= ffecom_integer_zero_node
;
1230 inits
= build_tree_list ((field
= TYPE_FIELDS (f2c_alist_struct
)), errinit
);
1232 ffeste_f2c_init_next_ (unitinit
);
1234 inits
= build_constructor (f2c_alist_struct
, inits
);
1235 TREE_CONSTANT (inits
) = constantp
? 1 : 0;
1236 TREE_STATIC (inits
) = 1;
1238 t
= build_decl (VAR_DECL
,
1239 ffecom_get_invented_identifier ("__g77_alist_%d",
1242 TREE_STATIC (t
) = 1;
1243 t
= ffecom_start_decl (t
, 1);
1244 ffecom_finish_decl (t
, inits
, 0);
1246 /* Prepare run-time expressions. */
1249 ffecom_prepare_expr (unit_expr
);
1251 ffecom_prepare_end ();
1253 /* Now evaluate run-time expressions as needed. */
1257 unitexp
= ffecom_expr (unit_expr
);
1258 ffeste_f2c_compile_ (unitfield
, unitexp
);
1261 ttype
= build_pointer_type (TREE_TYPE (t
));
1262 t
= ffecom_1 (ADDR_EXPR
, ttype
, t
);
1264 t
= build_tree_list (NULL_TREE
, t
);
1269 /* Make arglist with ptr to external-I/O control list.
1271 Returns a tree suitable as an argument list containing a pointer to
1272 an external-I/O control list. First, generates that control
1273 list, if necessary, along with any static and run-time initializations
1274 that are needed as specified by the arguments to this function.
1276 Must ensure that all expressions are prepared before being evaluated,
1277 for any whose evaluation might result in the generation of temporaries.
1279 Note that this means this function causes a transition, within the
1280 current block being code-generated via the back end, from the
1281 declaration of variables (temporaries) to the expanding of expressions,
1284 static GTY(()) tree f2c_cilist_struct
;
1286 ffeste_io_cilist_ (bool have_err
,
1291 ffestvFormat format
,
1292 ffestpFile
*format_spec
,
1300 bool constantp
= TRUE
;
1301 static tree errfield
, unitfield
, endfield
, formatfield
, recfield
;
1302 tree errinit
, unitinit
, endinit
, formatinit
, recinit
;
1303 tree unitexp
, formatexp
, recexp
;
1304 static int mynumber
= 0;
1306 if (f2c_cilist_struct
== NULL_TREE
)
1310 ref
= make_node (RECORD_TYPE
);
1312 errfield
= ffecom_decl_field (ref
, NULL_TREE
, "err",
1313 ffecom_f2c_flag_type_node
);
1314 unitfield
= ffecom_decl_field (ref
, errfield
, "unit",
1315 ffecom_f2c_ftnint_type_node
);
1316 endfield
= ffecom_decl_field (ref
, unitfield
, "end",
1317 ffecom_f2c_flag_type_node
);
1318 formatfield
= ffecom_decl_field (ref
, endfield
, "format",
1320 recfield
= ffecom_decl_field (ref
, formatfield
, "rec",
1321 ffecom_f2c_ftnint_type_node
);
1323 TYPE_FIELDS (ref
) = errfield
;
1326 f2c_cilist_struct
= ref
;
1329 /* Try to do as much compile-time initialization of the structure
1330 as possible, to save run time. */
1332 ffeste_f2c_init_flag_ (have_err
, errinit
);
1336 case FFESTV_unitNONE
:
1337 case FFESTV_unitASTERISK
:
1338 unitinit
= build_int_2 (unit_dflt
, 0);
1342 case FFESTV_unitINTEXPR
:
1343 unitexp
= ffecom_const_expr (unit_expr
);
1348 unitinit
= ffecom_integer_zero_node
;
1354 assert ("bad unit spec" == NULL
);
1355 unitinit
= ffecom_integer_zero_node
;
1362 case FFESTV_formatNONE
:
1363 formatinit
= null_pointer_node
;
1364 formatexp
= formatinit
;
1367 case FFESTV_formatLABEL
:
1368 formatexp
= error_mark_node
;
1369 formatinit
= ffecom_lookup_label (format_spec
->u
.label
);
1370 if ((formatinit
== NULL_TREE
)
1371 || (TREE_CODE (formatinit
) == ERROR_MARK
))
1373 formatinit
= ffecom_1 (ADDR_EXPR
,
1374 build_pointer_type (void_type_node
),
1376 TREE_CONSTANT (formatinit
) = 1;
1379 case FFESTV_formatCHAREXPR
:
1380 formatexp
= ffecom_arg_ptr_to_const_expr (format_spec
->u
.expr
, NULL
);
1382 formatinit
= formatexp
;
1385 formatinit
= null_pointer_node
;
1390 case FFESTV_formatASTERISK
:
1391 formatinit
= null_pointer_node
;
1392 formatexp
= formatinit
;
1395 case FFESTV_formatINTEXPR
:
1396 formatinit
= null_pointer_node
;
1397 formatexp
= ffecom_expr_assign (format_spec
->u
.expr
);
1398 if (GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (formatexp
)))
1399 < GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node
))))
1400 error ("ASSIGNed FORMAT specifier is too small");
1401 formatexp
= convert (string_type_node
, formatexp
);
1404 case FFESTV_formatNAMELIST
:
1405 formatinit
= ffecom_expr (format_spec
->u
.expr
);
1406 formatexp
= formatinit
;
1410 assert ("bad format spec" == NULL
);
1411 formatinit
= integer_zero_node
;
1412 formatexp
= formatinit
;
1416 ffeste_f2c_init_flag_ (have_end
, endinit
);
1419 recexp
= ffecom_const_expr (rec_expr
);
1421 recexp
= ffecom_integer_zero_node
;
1426 recinit
= ffecom_integer_zero_node
;
1430 inits
= build_tree_list ((field
= TYPE_FIELDS (f2c_cilist_struct
)), errinit
);
1432 ffeste_f2c_init_next_ (unitinit
);
1433 ffeste_f2c_init_next_ (endinit
);
1434 ffeste_f2c_init_next_ (formatinit
);
1435 ffeste_f2c_init_next_ (recinit
);
1437 inits
= build_constructor (f2c_cilist_struct
, inits
);
1438 TREE_CONSTANT (inits
) = constantp
? 1 : 0;
1439 TREE_STATIC (inits
) = 1;
1441 t
= build_decl (VAR_DECL
,
1442 ffecom_get_invented_identifier ("__g77_cilist_%d",
1445 TREE_STATIC (t
) = 1;
1446 t
= ffecom_start_decl (t
, 1);
1447 ffecom_finish_decl (t
, inits
, 0);
1449 /* Prepare run-time expressions. */
1452 ffecom_prepare_expr (unit_expr
);
1455 ffecom_prepare_arg_ptr_to_expr (format_spec
->u
.expr
);
1458 ffecom_prepare_expr (rec_expr
);
1460 ffecom_prepare_end ();
1462 /* Now evaluate run-time expressions as needed. */
1466 unitexp
= ffecom_expr (unit_expr
);
1467 ffeste_f2c_compile_ (unitfield
, unitexp
);
1472 formatexp
= ffecom_arg_ptr_to_expr (format_spec
->u
.expr
, NULL
);
1473 ffeste_f2c_compile_ (formatfield
, formatexp
);
1475 else if (format
== FFESTV_formatINTEXPR
)
1476 ffeste_f2c_compile_ (formatfield
, formatexp
);
1480 recexp
= ffecom_expr (rec_expr
);
1481 ffeste_f2c_compile_ (recfield
, recexp
);
1484 ttype
= build_pointer_type (TREE_TYPE (t
));
1485 t
= ffecom_1 (ADDR_EXPR
, ttype
, t
);
1487 t
= build_tree_list (NULL_TREE
, t
);
1492 /* Make arglist with ptr to CLOSE control list.
1494 Returns a tree suitable as an argument list containing a pointer to
1495 a CLOSE-statement control list. First, generates that control
1496 list, if necessary, along with any static and run-time initializations
1497 that are needed as specified by the arguments to this function.
1499 Must ensure that all expressions are prepared before being evaluated,
1500 for any whose evaluation might result in the generation of temporaries.
1502 Note that this means this function causes a transition, within the
1503 current block being code-generated via the back end, from the
1504 declaration of variables (temporaries) to the expanding of expressions,
1507 static GTY(()) tree f2c_close_struct
;
1509 ffeste_io_cllist_ (bool have_err
,
1511 ffestpFile
*stat_spec
)
1517 tree ignore
; /* Ignore length info for certain fields. */
1518 bool constantp
= TRUE
;
1519 static tree errfield
, unitfield
, statfield
;
1520 tree errinit
, unitinit
, statinit
;
1521 tree unitexp
, statexp
;
1522 static int mynumber
= 0;
1524 if (f2c_close_struct
== NULL_TREE
)
1528 ref
= make_node (RECORD_TYPE
);
1530 errfield
= ffecom_decl_field (ref
, NULL_TREE
, "err",
1531 ffecom_f2c_flag_type_node
);
1532 unitfield
= ffecom_decl_field (ref
, errfield
, "unit",
1533 ffecom_f2c_ftnint_type_node
);
1534 statfield
= ffecom_decl_field (ref
, unitfield
, "stat",
1537 TYPE_FIELDS (ref
) = errfield
;
1540 f2c_close_struct
= ref
;
1543 /* Try to do as much compile-time initialization of the structure
1544 as possible, to save run time. */
1546 ffeste_f2c_init_flag_ (have_err
, errinit
);
1548 unitexp
= ffecom_const_expr (unit_expr
);
1553 unitinit
= ffecom_integer_zero_node
;
1557 ffeste_f2c_init_charnolen_ (statexp
, statinit
, stat_spec
);
1559 inits
= build_tree_list ((field
= TYPE_FIELDS (f2c_close_struct
)), errinit
);
1561 ffeste_f2c_init_next_ (unitinit
);
1562 ffeste_f2c_init_next_ (statinit
);
1564 inits
= build_constructor (f2c_close_struct
, inits
);
1565 TREE_CONSTANT (inits
) = constantp
? 1 : 0;
1566 TREE_STATIC (inits
) = 1;
1568 t
= build_decl (VAR_DECL
,
1569 ffecom_get_invented_identifier ("__g77_cllist_%d",
1572 TREE_STATIC (t
) = 1;
1573 t
= ffecom_start_decl (t
, 1);
1574 ffecom_finish_decl (t
, inits
, 0);
1576 /* Prepare run-time expressions. */
1579 ffecom_prepare_expr (unit_expr
);
1582 ffecom_prepare_arg_ptr_to_expr (stat_spec
->u
.expr
);
1584 ffecom_prepare_end ();
1586 /* Now evaluate run-time expressions as needed. */
1590 unitexp
= ffecom_expr (unit_expr
);
1591 ffeste_f2c_compile_ (unitfield
, unitexp
);
1594 ffeste_f2c_compile_charnolen_ (statfield
, stat_spec
, statexp
);
1596 ttype
= build_pointer_type (TREE_TYPE (t
));
1597 t
= ffecom_1 (ADDR_EXPR
, ttype
, t
);
1599 t
= build_tree_list (NULL_TREE
, t
);
1604 /* Make arglist with ptr to internal-I/O control list.
1606 Returns a tree suitable as an argument list containing a pointer to
1607 an internal-I/O control list. First, generates that control
1608 list, if necessary, along with any static and run-time initializations
1609 that are needed as specified by the arguments to this function.
1611 Must ensure that all expressions are prepared before being evaluated,
1612 for any whose evaluation might result in the generation of temporaries.
1614 Note that this means this function causes a transition, within the
1615 current block being code-generated via the back end, from the
1616 declaration of variables (temporaries) to the expanding of expressions,
1619 static GTY(()) tree f2c_icilist_struct
;
1621 ffeste_io_icilist_ (bool have_err
,
1624 ffestvFormat format
,
1625 ffestpFile
*format_spec
)
1631 bool constantp
= TRUE
;
1632 static tree errfield
, unitfield
, endfield
, formatfield
, unitlenfield
,
1634 tree errinit
, unitinit
, endinit
, formatinit
, unitleninit
, unitnuminit
;
1635 tree unitexp
, formatexp
, unitlenexp
, unitnumexp
;
1636 static int mynumber
= 0;
1638 if (f2c_icilist_struct
== NULL_TREE
)
1642 ref
= make_node (RECORD_TYPE
);
1644 errfield
= ffecom_decl_field (ref
, NULL_TREE
, "err",
1645 ffecom_f2c_flag_type_node
);
1646 unitfield
= ffecom_decl_field (ref
, errfield
, "unit",
1648 endfield
= ffecom_decl_field (ref
, unitfield
, "end",
1649 ffecom_f2c_flag_type_node
);
1650 formatfield
= ffecom_decl_field (ref
, endfield
, "format",
1652 unitlenfield
= ffecom_decl_field (ref
, formatfield
, "unitlen",
1653 ffecom_f2c_ftnint_type_node
);
1654 unitnumfield
= ffecom_decl_field (ref
, unitlenfield
, "unitnum",
1655 ffecom_f2c_ftnint_type_node
);
1657 TYPE_FIELDS (ref
) = errfield
;
1660 f2c_icilist_struct
= ref
;
1663 /* Try to do as much compile-time initialization of the structure
1664 as possible, to save run time. */
1666 ffeste_f2c_init_flag_ (have_err
, errinit
);
1668 unitexp
= ffecom_arg_ptr_to_const_expr (unit_expr
, &unitlenexp
);
1673 unitinit
= null_pointer_node
;
1677 unitleninit
= unitlenexp
;
1680 unitleninit
= ffecom_integer_zero_node
;
1684 /* Now see if we can fully initialize the number of elements, or
1685 if we have to compute that at run time. */
1686 if (ffeinfo_rank (ffebld_info (unit_expr
)) == 0
1688 && TREE_CODE (TREE_TYPE (TREE_TYPE (unitexp
))) != ARRAY_TYPE
))
1690 /* Not an array, so just one element. */
1691 unitnuminit
= ffecom_integer_one_node
;
1692 unitnumexp
= unitnuminit
;
1694 else if (unitexp
&& unitlenexp
)
1696 /* An array, but all the info is constant, so compute now. */
1698 = size_binop (CEIL_DIV_EXPR
,
1699 TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (unitexp
))),
1700 convert (sizetype
, unitlenexp
));
1701 unitnuminit
= size_binop (CEIL_DIV_EXPR
, unitnuminit
,
1702 size_int (TYPE_PRECISION (char_type_node
)
1704 unitnumexp
= unitnuminit
;
1708 /* Put off computing until run time. */
1709 unitnuminit
= ffecom_integer_zero_node
;
1710 unitnumexp
= NULL_TREE
;
1716 case FFESTV_formatNONE
:
1717 formatinit
= null_pointer_node
;
1718 formatexp
= formatinit
;
1721 case FFESTV_formatLABEL
:
1722 formatexp
= error_mark_node
;
1723 formatinit
= ffecom_lookup_label (format_spec
->u
.label
);
1724 if ((formatinit
== NULL_TREE
)
1725 || (TREE_CODE (formatinit
) == ERROR_MARK
))
1727 formatinit
= ffecom_1 (ADDR_EXPR
,
1728 build_pointer_type (void_type_node
),
1730 TREE_CONSTANT (formatinit
) = 1;
1733 case FFESTV_formatCHAREXPR
:
1734 ffeste_f2c_init_format_ (formatexp
, formatinit
, format_spec
);
1737 case FFESTV_formatASTERISK
:
1738 formatinit
= null_pointer_node
;
1739 formatexp
= formatinit
;
1742 case FFESTV_formatINTEXPR
:
1743 formatinit
= null_pointer_node
;
1744 formatexp
= ffecom_expr_assign (format_spec
->u
.expr
);
1745 if (GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (formatexp
)))
1746 < GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node
))))
1747 error ("ASSIGNed FORMAT specifier is too small");
1748 formatexp
= convert (string_type_node
, formatexp
);
1752 assert ("bad format spec" == NULL
);
1753 formatinit
= ffecom_integer_zero_node
;
1754 formatexp
= formatinit
;
1758 ffeste_f2c_init_flag_ (have_end
, endinit
);
1760 inits
= build_tree_list ((field
= TYPE_FIELDS (f2c_icilist_struct
)),
1763 ffeste_f2c_init_next_ (unitinit
);
1764 ffeste_f2c_init_next_ (endinit
);
1765 ffeste_f2c_init_next_ (formatinit
);
1766 ffeste_f2c_init_next_ (unitleninit
);
1767 ffeste_f2c_init_next_ (unitnuminit
);
1769 inits
= build_constructor (f2c_icilist_struct
, inits
);
1770 TREE_CONSTANT (inits
) = constantp
? 1 : 0;
1771 TREE_STATIC (inits
) = 1;
1773 t
= build_decl (VAR_DECL
,
1774 ffecom_get_invented_identifier ("__g77_icilist_%d",
1776 f2c_icilist_struct
);
1777 TREE_STATIC (t
) = 1;
1778 t
= ffecom_start_decl (t
, 1);
1779 ffecom_finish_decl (t
, inits
, 0);
1781 /* Prepare run-time expressions. */
1784 ffecom_prepare_arg_ptr_to_expr (unit_expr
);
1786 ffeste_f2c_prepare_format_ (format_spec
, formatexp
);
1788 ffecom_prepare_end ();
1790 /* Now evaluate run-time expressions as needed. */
1792 if (! unitexp
|| ! unitlenexp
)
1794 int need_unitexp
= (! unitexp
);
1795 int need_unitlenexp
= (! unitlenexp
);
1797 unitexp
= ffecom_arg_ptr_to_expr (unit_expr
, &unitlenexp
);
1799 ffeste_f2c_compile_ (unitfield
, unitexp
);
1800 if (need_unitlenexp
)
1801 ffeste_f2c_compile_ (unitlenfield
, unitlenexp
);
1805 && unitexp
!= error_mark_node
1806 && unitlenexp
!= error_mark_node
)
1809 = size_binop (CEIL_DIV_EXPR
,
1810 TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (unitexp
))),
1811 convert (sizetype
, unitlenexp
));
1812 unitnumexp
= size_binop (CEIL_DIV_EXPR
, unitnumexp
,
1813 size_int (TYPE_PRECISION (char_type_node
)
1815 ffeste_f2c_compile_ (unitnumfield
, unitnumexp
);
1818 if (format
== FFESTV_formatINTEXPR
)
1819 ffeste_f2c_compile_ (formatfield
, formatexp
);
1821 ffeste_f2c_compile_format_ (formatfield
, format_spec
, formatexp
);
1823 ttype
= build_pointer_type (TREE_TYPE (t
));
1824 t
= ffecom_1 (ADDR_EXPR
, ttype
, t
);
1826 t
= build_tree_list (NULL_TREE
, t
);
1831 /* Make arglist with ptr to INQUIRE control list
1833 Returns a tree suitable as an argument list containing a pointer to
1834 an INQUIRE-statement control list. First, generates that control
1835 list, if necessary, along with any static and run-time initializations
1836 that are needed as specified by the arguments to this function.
1838 Must ensure that all expressions are prepared before being evaluated,
1839 for any whose evaluation might result in the generation of temporaries.
1841 Note that this means this function causes a transition, within the
1842 current block being code-generated via the back end, from the
1843 declaration of variables (temporaries) to the expanding of expressions,
1846 static GTY(()) tree f2c_inquire_struct
;
1848 ffeste_io_inlist_ (bool have_err
,
1849 ffestpFile
*unit_spec
,
1850 ffestpFile
*file_spec
,
1851 ffestpFile
*exist_spec
,
1852 ffestpFile
*open_spec
,
1853 ffestpFile
*number_spec
,
1854 ffestpFile
*named_spec
,
1855 ffestpFile
*name_spec
,
1856 ffestpFile
*access_spec
,
1857 ffestpFile
*sequential_spec
,
1858 ffestpFile
*direct_spec
,
1859 ffestpFile
*form_spec
,
1860 ffestpFile
*formatted_spec
,
1861 ffestpFile
*unformatted_spec
,
1862 ffestpFile
*recl_spec
,
1863 ffestpFile
*nextrec_spec
,
1864 ffestpFile
*blank_spec
)
1870 bool constantp
= TRUE
;
1871 static tree errfield
, unitfield
, filefield
, filelenfield
, existfield
,
1872 openfield
, numberfield
, namedfield
, namefield
, namelenfield
, accessfield
,
1873 accesslenfield
, sequentialfield
, sequentiallenfield
, directfield
, directlenfield
,
1874 formfield
, formlenfield
, formattedfield
, formattedlenfield
, unformattedfield
,
1875 unformattedlenfield
, reclfield
, nextrecfield
, blankfield
, blanklenfield
;
1876 tree errinit
, unitinit
, fileinit
, fileleninit
, existinit
, openinit
, numberinit
,
1877 namedinit
, nameinit
, nameleninit
, accessinit
, accessleninit
, sequentialinit
,
1878 sequentialleninit
, directinit
, directleninit
, forminit
, formleninit
,
1879 formattedinit
, formattedleninit
, unformattedinit
, unformattedleninit
,
1880 reclinit
, nextrecinit
, blankinit
, blankleninit
;
1882 unitexp
, fileexp
, filelenexp
, existexp
, openexp
, numberexp
, namedexp
,
1883 nameexp
, namelenexp
, accessexp
, accesslenexp
, sequentialexp
, sequentiallenexp
,
1884 directexp
, directlenexp
, formexp
, formlenexp
, formattedexp
, formattedlenexp
,
1885 unformattedexp
, unformattedlenexp
, reclexp
, nextrecexp
, blankexp
, blanklenexp
;
1886 static int mynumber
= 0;
1888 if (f2c_inquire_struct
== NULL_TREE
)
1892 ref
= make_node (RECORD_TYPE
);
1894 errfield
= ffecom_decl_field (ref
, NULL_TREE
, "err",
1895 ffecom_f2c_flag_type_node
);
1896 unitfield
= ffecom_decl_field (ref
, errfield
, "unit",
1897 ffecom_f2c_ftnint_type_node
);
1898 filefield
= ffecom_decl_field (ref
, unitfield
, "file",
1900 filelenfield
= ffecom_decl_field (ref
, filefield
, "filelen",
1901 ffecom_f2c_ftnlen_type_node
);
1902 existfield
= ffecom_decl_field (ref
, filelenfield
, "exist",
1903 ffecom_f2c_ptr_to_ftnint_type_node
);
1904 openfield
= ffecom_decl_field (ref
, existfield
, "open",
1905 ffecom_f2c_ptr_to_ftnint_type_node
);
1906 numberfield
= ffecom_decl_field (ref
, openfield
, "number",
1907 ffecom_f2c_ptr_to_ftnint_type_node
);
1908 namedfield
= ffecom_decl_field (ref
, numberfield
, "named",
1909 ffecom_f2c_ptr_to_ftnint_type_node
);
1910 namefield
= ffecom_decl_field (ref
, namedfield
, "name",
1912 namelenfield
= ffecom_decl_field (ref
, namefield
, "namelen",
1913 ffecom_f2c_ftnlen_type_node
);
1914 accessfield
= ffecom_decl_field (ref
, namelenfield
, "access",
1916 accesslenfield
= ffecom_decl_field (ref
, accessfield
, "accesslen",
1917 ffecom_f2c_ftnlen_type_node
);
1918 sequentialfield
= ffecom_decl_field (ref
, accesslenfield
, "sequential",
1920 sequentiallenfield
= ffecom_decl_field (ref
, sequentialfield
,
1922 ffecom_f2c_ftnlen_type_node
);
1923 directfield
= ffecom_decl_field (ref
, sequentiallenfield
, "direct",
1925 directlenfield
= ffecom_decl_field (ref
, directfield
, "directlen",
1926 ffecom_f2c_ftnlen_type_node
);
1927 formfield
= ffecom_decl_field (ref
, directlenfield
, "form",
1929 formlenfield
= ffecom_decl_field (ref
, formfield
, "formlen",
1930 ffecom_f2c_ftnlen_type_node
);
1931 formattedfield
= ffecom_decl_field (ref
, formlenfield
, "formatted",
1933 formattedlenfield
= ffecom_decl_field (ref
, formattedfield
,
1935 ffecom_f2c_ftnlen_type_node
);
1936 unformattedfield
= ffecom_decl_field (ref
, formattedlenfield
,
1939 unformattedlenfield
= ffecom_decl_field (ref
, unformattedfield
,
1941 ffecom_f2c_ftnlen_type_node
);
1942 reclfield
= ffecom_decl_field (ref
, unformattedlenfield
, "recl",
1943 ffecom_f2c_ptr_to_ftnint_type_node
);
1944 nextrecfield
= ffecom_decl_field (ref
, reclfield
, "nextrec",
1945 ffecom_f2c_ptr_to_ftnint_type_node
);
1946 blankfield
= ffecom_decl_field (ref
, nextrecfield
, "blank",
1948 blanklenfield
= ffecom_decl_field (ref
, blankfield
, "blanklen",
1949 ffecom_f2c_ftnlen_type_node
);
1951 TYPE_FIELDS (ref
) = errfield
;
1954 f2c_inquire_struct
= ref
;
1957 /* Try to do as much compile-time initialization of the structure
1958 as possible, to save run time. */
1960 ffeste_f2c_init_flag_ (have_err
, errinit
);
1961 ffeste_f2c_init_int_ (unitexp
, unitinit
, unit_spec
);
1962 ffeste_f2c_init_char_ (fileexp
, fileinit
, filelenexp
, fileleninit
,
1964 ffeste_f2c_init_ptrtoint_ (existexp
, existinit
, exist_spec
);
1965 ffeste_f2c_init_ptrtoint_ (openexp
, openinit
, open_spec
);
1966 ffeste_f2c_init_ptrtoint_ (numberexp
, numberinit
, number_spec
);
1967 ffeste_f2c_init_ptrtoint_ (namedexp
, namedinit
, named_spec
);
1968 ffeste_f2c_init_char_ (nameexp
, nameinit
, namelenexp
, nameleninit
,
1970 ffeste_f2c_init_char_ (accessexp
, accessinit
, accesslenexp
,
1971 accessleninit
, access_spec
);
1972 ffeste_f2c_init_char_ (sequentialexp
, sequentialinit
, sequentiallenexp
,
1973 sequentialleninit
, sequential_spec
);
1974 ffeste_f2c_init_char_ (directexp
, directinit
, directlenexp
,
1975 directleninit
, direct_spec
);
1976 ffeste_f2c_init_char_ (formexp
, forminit
, formlenexp
, formleninit
,
1978 ffeste_f2c_init_char_ (formattedexp
, formattedinit
,
1979 formattedlenexp
, formattedleninit
, formatted_spec
);
1980 ffeste_f2c_init_char_ (unformattedexp
, unformattedinit
, unformattedlenexp
,
1981 unformattedleninit
, unformatted_spec
);
1982 ffeste_f2c_init_ptrtoint_ (reclexp
, reclinit
, recl_spec
);
1983 ffeste_f2c_init_ptrtoint_ (nextrecexp
, nextrecinit
, nextrec_spec
);
1984 ffeste_f2c_init_char_ (blankexp
, blankinit
, blanklenexp
,
1985 blankleninit
, blank_spec
);
1987 inits
= build_tree_list ((field
= TYPE_FIELDS (f2c_inquire_struct
)),
1990 ffeste_f2c_init_next_ (unitinit
);
1991 ffeste_f2c_init_next_ (fileinit
);
1992 ffeste_f2c_init_next_ (fileleninit
);
1993 ffeste_f2c_init_next_ (existinit
);
1994 ffeste_f2c_init_next_ (openinit
);
1995 ffeste_f2c_init_next_ (numberinit
);
1996 ffeste_f2c_init_next_ (namedinit
);
1997 ffeste_f2c_init_next_ (nameinit
);
1998 ffeste_f2c_init_next_ (nameleninit
);
1999 ffeste_f2c_init_next_ (accessinit
);
2000 ffeste_f2c_init_next_ (accessleninit
);
2001 ffeste_f2c_init_next_ (sequentialinit
);
2002 ffeste_f2c_init_next_ (sequentialleninit
);
2003 ffeste_f2c_init_next_ (directinit
);
2004 ffeste_f2c_init_next_ (directleninit
);
2005 ffeste_f2c_init_next_ (forminit
);
2006 ffeste_f2c_init_next_ (formleninit
);
2007 ffeste_f2c_init_next_ (formattedinit
);
2008 ffeste_f2c_init_next_ (formattedleninit
);
2009 ffeste_f2c_init_next_ (unformattedinit
);
2010 ffeste_f2c_init_next_ (unformattedleninit
);
2011 ffeste_f2c_init_next_ (reclinit
);
2012 ffeste_f2c_init_next_ (nextrecinit
);
2013 ffeste_f2c_init_next_ (blankinit
);
2014 ffeste_f2c_init_next_ (blankleninit
);
2016 inits
= build_constructor (f2c_inquire_struct
, inits
);
2017 TREE_CONSTANT (inits
) = constantp
? 1 : 0;
2018 TREE_STATIC (inits
) = 1;
2020 t
= build_decl (VAR_DECL
,
2021 ffecom_get_invented_identifier ("__g77_inlist_%d",
2023 f2c_inquire_struct
);
2024 TREE_STATIC (t
) = 1;
2025 t
= ffecom_start_decl (t
, 1);
2026 ffecom_finish_decl (t
, inits
, 0);
2028 /* Prepare run-time expressions. */
2030 ffeste_f2c_prepare_int_ (unit_spec
, unitexp
);
2031 ffeste_f2c_prepare_char_ (file_spec
, fileexp
);
2032 ffeste_f2c_prepare_ptrtoint_ (exist_spec
, existexp
);
2033 ffeste_f2c_prepare_ptrtoint_ (open_spec
, openexp
);
2034 ffeste_f2c_prepare_ptrtoint_ (number_spec
, numberexp
);
2035 ffeste_f2c_prepare_ptrtoint_ (named_spec
, namedexp
);
2036 ffeste_f2c_prepare_char_ (name_spec
, nameexp
);
2037 ffeste_f2c_prepare_char_ (access_spec
, accessexp
);
2038 ffeste_f2c_prepare_char_ (sequential_spec
, sequentialexp
);
2039 ffeste_f2c_prepare_char_ (direct_spec
, directexp
);
2040 ffeste_f2c_prepare_char_ (form_spec
, formexp
);
2041 ffeste_f2c_prepare_char_ (formatted_spec
, formattedexp
);
2042 ffeste_f2c_prepare_char_ (unformatted_spec
, unformattedexp
);
2043 ffeste_f2c_prepare_ptrtoint_ (recl_spec
, reclexp
);
2044 ffeste_f2c_prepare_ptrtoint_ (nextrec_spec
, nextrecexp
);
2045 ffeste_f2c_prepare_char_ (blank_spec
, blankexp
);
2047 ffecom_prepare_end ();
2049 /* Now evaluate run-time expressions as needed. */
2051 ffeste_f2c_compile_int_ (unitfield
, unit_spec
, unitexp
);
2052 ffeste_f2c_compile_char_ (filefield
, filelenfield
, file_spec
,
2053 fileexp
, filelenexp
);
2054 ffeste_f2c_compile_ptrtoint_ (existfield
, exist_spec
, existexp
);
2055 ffeste_f2c_compile_ptrtoint_ (openfield
, open_spec
, openexp
);
2056 ffeste_f2c_compile_ptrtoint_ (numberfield
, number_spec
, numberexp
);
2057 ffeste_f2c_compile_ptrtoint_ (namedfield
, named_spec
, namedexp
);
2058 ffeste_f2c_compile_char_ (namefield
, namelenfield
, name_spec
, nameexp
,
2060 ffeste_f2c_compile_char_ (accessfield
, accesslenfield
, access_spec
,
2061 accessexp
, accesslenexp
);
2062 ffeste_f2c_compile_char_ (sequentialfield
, sequentiallenfield
,
2063 sequential_spec
, sequentialexp
,
2065 ffeste_f2c_compile_char_ (directfield
, directlenfield
, direct_spec
,
2066 directexp
, directlenexp
);
2067 ffeste_f2c_compile_char_ (formfield
, formlenfield
, form_spec
, formexp
,
2069 ffeste_f2c_compile_char_ (formattedfield
, formattedlenfield
, formatted_spec
,
2070 formattedexp
, formattedlenexp
);
2071 ffeste_f2c_compile_char_ (unformattedfield
, unformattedlenfield
,
2072 unformatted_spec
, unformattedexp
,
2074 ffeste_f2c_compile_ptrtoint_ (reclfield
, recl_spec
, reclexp
);
2075 ffeste_f2c_compile_ptrtoint_ (nextrecfield
, nextrec_spec
, nextrecexp
);
2076 ffeste_f2c_compile_char_ (blankfield
, blanklenfield
, blank_spec
, blankexp
,
2079 ttype
= build_pointer_type (TREE_TYPE (t
));
2080 t
= ffecom_1 (ADDR_EXPR
, ttype
, t
);
2082 t
= build_tree_list (NULL_TREE
, t
);
2087 /* Make arglist with ptr to OPEN control list
2089 Returns a tree suitable as an argument list containing a pointer to
2090 an OPEN-statement control list. First, generates that control
2091 list, if necessary, along with any static and run-time initializations
2092 that are needed as specified by the arguments to this function.
2094 Must ensure that all expressions are prepared before being evaluated,
2095 for any whose evaluation might result in the generation of temporaries.
2097 Note that this means this function causes a transition, within the
2098 current block being code-generated via the back end, from the
2099 declaration of variables (temporaries) to the expanding of expressions,
2102 static GTY(()) tree f2c_open_struct
;
2104 ffeste_io_olist_ (bool have_err
,
2106 ffestpFile
*file_spec
,
2107 ffestpFile
*stat_spec
,
2108 ffestpFile
*access_spec
,
2109 ffestpFile
*form_spec
,
2110 ffestpFile
*recl_spec
,
2111 ffestpFile
*blank_spec
)
2117 tree ignore
; /* Ignore length info for certain fields. */
2118 bool constantp
= TRUE
;
2119 static tree errfield
, unitfield
, filefield
, filelenfield
, statfield
,
2120 accessfield
, formfield
, reclfield
, blankfield
;
2121 tree errinit
, unitinit
, fileinit
, fileleninit
, statinit
, accessinit
,
2122 forminit
, reclinit
, blankinit
;
2124 unitexp
, fileexp
, filelenexp
, statexp
, accessexp
, formexp
, reclexp
,
2126 static int mynumber
= 0;
2128 if (f2c_open_struct
== NULL_TREE
)
2132 ref
= make_node (RECORD_TYPE
);
2134 errfield
= ffecom_decl_field (ref
, NULL_TREE
, "err",
2135 ffecom_f2c_flag_type_node
);
2136 unitfield
= ffecom_decl_field (ref
, errfield
, "unit",
2137 ffecom_f2c_ftnint_type_node
);
2138 filefield
= ffecom_decl_field (ref
, unitfield
, "file",
2140 filelenfield
= ffecom_decl_field (ref
, filefield
, "filelen",
2141 ffecom_f2c_ftnlen_type_node
);
2142 statfield
= ffecom_decl_field (ref
, filelenfield
, "stat",
2144 accessfield
= ffecom_decl_field (ref
, statfield
, "access",
2146 formfield
= ffecom_decl_field (ref
, accessfield
, "form",
2148 reclfield
= ffecom_decl_field (ref
, formfield
, "recl",
2149 ffecom_f2c_ftnint_type_node
);
2150 blankfield
= ffecom_decl_field (ref
, reclfield
, "blank",
2153 TYPE_FIELDS (ref
) = errfield
;
2156 f2c_open_struct
= ref
;
2159 /* Try to do as much compile-time initialization of the structure
2160 as possible, to save run time. */
2162 ffeste_f2c_init_flag_ (have_err
, errinit
);
2164 unitexp
= ffecom_const_expr (unit_expr
);
2169 unitinit
= ffecom_integer_zero_node
;
2173 ffeste_f2c_init_char_ (fileexp
, fileinit
, filelenexp
, fileleninit
,
2175 ffeste_f2c_init_charnolen_ (statexp
, statinit
, stat_spec
);
2176 ffeste_f2c_init_charnolen_ (accessexp
, accessinit
, access_spec
);
2177 ffeste_f2c_init_charnolen_ (formexp
, forminit
, form_spec
);
2178 ffeste_f2c_init_int_ (reclexp
, reclinit
, recl_spec
);
2179 ffeste_f2c_init_charnolen_ (blankexp
, blankinit
, blank_spec
);
2181 inits
= build_tree_list ((field
= TYPE_FIELDS (f2c_open_struct
)), errinit
);
2183 ffeste_f2c_init_next_ (unitinit
);
2184 ffeste_f2c_init_next_ (fileinit
);
2185 ffeste_f2c_init_next_ (fileleninit
);
2186 ffeste_f2c_init_next_ (statinit
);
2187 ffeste_f2c_init_next_ (accessinit
);
2188 ffeste_f2c_init_next_ (forminit
);
2189 ffeste_f2c_init_next_ (reclinit
);
2190 ffeste_f2c_init_next_ (blankinit
);
2192 inits
= build_constructor (f2c_open_struct
, inits
);
2193 TREE_CONSTANT (inits
) = constantp
? 1 : 0;
2194 TREE_STATIC (inits
) = 1;
2196 t
= build_decl (VAR_DECL
,
2197 ffecom_get_invented_identifier ("__g77_olist_%d",
2200 TREE_STATIC (t
) = 1;
2201 t
= ffecom_start_decl (t
, 1);
2202 ffecom_finish_decl (t
, inits
, 0);
2204 /* Prepare run-time expressions. */
2207 ffecom_prepare_expr (unit_expr
);
2209 ffeste_f2c_prepare_char_ (file_spec
, fileexp
);
2210 ffeste_f2c_prepare_charnolen_ (stat_spec
, statexp
);
2211 ffeste_f2c_prepare_charnolen_ (access_spec
, accessexp
);
2212 ffeste_f2c_prepare_charnolen_ (form_spec
, formexp
);
2213 ffeste_f2c_prepare_int_ (recl_spec
, reclexp
);
2214 ffeste_f2c_prepare_charnolen_ (blank_spec
, blankexp
);
2216 ffecom_prepare_end ();
2218 /* Now evaluate run-time expressions as needed. */
2222 unitexp
= ffecom_expr (unit_expr
);
2223 ffeste_f2c_compile_ (unitfield
, unitexp
);
2226 ffeste_f2c_compile_char_ (filefield
, filelenfield
, file_spec
, fileexp
,
2228 ffeste_f2c_compile_charnolen_ (statfield
, stat_spec
, statexp
);
2229 ffeste_f2c_compile_charnolen_ (accessfield
, access_spec
, accessexp
);
2230 ffeste_f2c_compile_charnolen_ (formfield
, form_spec
, formexp
);
2231 ffeste_f2c_compile_int_ (reclfield
, recl_spec
, reclexp
);
2232 ffeste_f2c_compile_charnolen_ (blankfield
, blank_spec
, blankexp
);
2234 ttype
= build_pointer_type (TREE_TYPE (t
));
2235 t
= ffecom_1 (ADDR_EXPR
, ttype
, t
);
2237 t
= build_tree_list (NULL_TREE
, t
);
2242 /* Generate code for BACKSPACE/ENDFILE/REWIND. */
2245 ffeste_subr_beru_ (ffestpBeruStmt
*info
, ffecomGfrt rt
)
2251 ffeste_emit_line_note_ ();
2253 #define specified(something) (info->beru_spec[something].kw_or_val_present)
2255 iostat
= specified (FFESTP_beruixIOSTAT
);
2256 errl
= specified (FFESTP_beruixERR
);
2260 /* ~~For now, we assume the unit number is specified and is not ASTERISK,
2261 because the FFE doesn't support BACKSPACE(*) and rejects a BACKSPACE
2262 without any unit specifier. f2c, however, supports the former
2263 construct. When it is time to add this feature to the FFE, which
2264 probably is fairly easy, ffestc_R919 and company will want to pass an
2265 ffestvUnit indicator of FFESTV_unitINTEXPR or _unitASTERISK to
2266 ffeste_R919 and company, and they will want to pass that same value to
2267 this function, and that argument will replace the constant _unitINTEXPR_
2268 in the call below. Right now, the default unit number, 6, is ignored. */
2270 ffeste_start_stmt_ ();
2274 /* Have ERR= specification. */
2278 = ffecom_lookup_label
2279 (info
->beru_spec
[FFESTP_beruixERR
].u
.label
);
2280 ffeste_io_abort_is_temp_
= FALSE
;
2284 /* No ERR= specification. */
2286 ffeste_io_err_
= NULL_TREE
;
2288 if ((ffeste_io_abort_is_temp_
= iostat
))
2289 ffeste_io_abort_
= ffecom_temp_label ();
2291 ffeste_io_abort_
= NULL_TREE
;
2296 /* Have IOSTAT= specification. */
2298 ffeste_io_iostat_is_temp_
= FALSE
;
2299 ffeste_io_iostat_
= ffecom_expr
2300 (info
->beru_spec
[FFESTP_beruixIOSTAT
].u
.expr
);
2302 else if (ffeste_io_abort_
!= NULL_TREE
)
2304 /* Have no IOSTAT= but have ERR=. */
2306 ffeste_io_iostat_is_temp_
= TRUE
;
2308 = ffecom_make_tempvar ("beru", ffecom_integer_type_node
,
2309 FFETARGET_charactersizeNONE
, -1);
2313 /* No IOSTAT= or ERR= specification. */
2315 ffeste_io_iostat_is_temp_
= FALSE
;
2316 ffeste_io_iostat_
= NULL_TREE
;
2319 /* Now prescan, then convert, all the arguments. */
2321 alist
= ffeste_io_ialist_ (errl
|| iostat
, FFESTV_unitINTEXPR
,
2322 info
->beru_spec
[FFESTP_beruixUNIT
].u
.expr
, 6);
2324 /* Don't generate "if (iostat != 0) goto label;" if label is temp abort
2325 label, since we're gonna fall through to there anyway. */
2327 ffeste_io_call_ (ffecom_call_gfrt (rt
, alist
, NULL_TREE
),
2328 ! ffeste_io_abort_is_temp_
);
2330 /* If we've got a temp label, generate its code here. */
2332 if (ffeste_io_abort_is_temp_
)
2334 DECL_INITIAL (ffeste_io_abort_
) = error_mark_node
;
2336 expand_label (ffeste_io_abort_
);
2338 assert (ffeste_io_err_
== NULL_TREE
);
2341 ffeste_end_stmt_ ();
2346 Also invoked by _labeldef_branch_finish_ (or, in cases
2347 of errors, other _labeldef_ functions) when the label definition is
2348 for a DO-target (LOOPEND) label, once per matching/outstanding DO
2349 block on the stack. */
2352 ffeste_do (ffestw block
)
2354 ffeste_emit_line_note_ ();
2356 if (ffestw_do_tvar (block
) == 0)
2358 expand_end_loop (); /* DO WHILE and just DO. */
2360 ffeste_end_block_ (block
);
2363 ffeste_end_iterdo_ (block
,
2364 ffestw_do_tvar (block
),
2365 ffestw_do_incr_saved (block
),
2366 ffestw_do_count_var (block
));
2369 /* End of statement following logical IF.
2371 Applies to *only* logical IF, not to IF-THEN. */
2376 ffeste_emit_line_note_ ();
2380 ffeste_end_block_ (NULL
);
2383 /* Generate "code" for branch label definition. */
2386 ffeste_labeldef_branch (ffelab label
)
2390 glabel
= ffecom_lookup_label (label
);
2391 assert (glabel
!= NULL_TREE
);
2392 if (TREE_CODE (glabel
) == ERROR_MARK
)
2395 assert (DECL_INITIAL (glabel
) == NULL_TREE
);
2397 DECL_INITIAL (glabel
) = error_mark_node
;
2398 DECL_SOURCE_FILE (glabel
) = ffelab_definition_filename (label
);
2399 DECL_SOURCE_LINE (glabel
) = ffelab_definition_filelinenum (label
);
2403 expand_label (glabel
);
2406 /* Generate "code" for FORMAT label definition. */
2409 ffeste_labeldef_format (ffelab label
)
2411 ffeste_label_formatdef_
= label
;
2414 /* Assignment statement (outside of WHERE). */
2417 ffeste_R737A (ffebld dest
, ffebld source
)
2419 ffeste_check_simple_ ();
2421 ffeste_emit_line_note_ ();
2423 ffeste_start_stmt_ ();
2425 ffecom_expand_let_stmt (dest
, source
);
2427 ffeste_end_stmt_ ();
2430 /* Block IF (IF-THEN) statement. */
2433 ffeste_R803 (ffestw block
, ffebld expr
)
2437 ffeste_check_simple_ ();
2439 ffeste_emit_line_note_ ();
2441 ffeste_start_block_ (block
);
2443 temp
= ffecom_make_tempvar ("ifthen", integer_type_node
,
2444 FFETARGET_charactersizeNONE
, -1);
2446 ffeste_start_stmt_ ();
2448 ffecom_prepare_expr (expr
);
2450 if (ffecom_prepare_end ())
2454 result
= ffecom_modify (void_type_node
,
2456 ffecom_truth_value (ffecom_expr (expr
)));
2458 expand_expr_stmt (result
);
2460 ffeste_end_stmt_ ();
2464 ffeste_end_stmt_ ();
2466 temp
= ffecom_truth_value (ffecom_expr (expr
));
2469 expand_start_cond (temp
, 0);
2471 /* No fake `else' constructs introduced (yet). */
2472 ffestw_set_ifthen_fake_else (block
, 0);
2475 /* ELSE IF statement. */
2478 ffeste_R804 (ffestw block
, ffebld expr
)
2482 ffeste_check_simple_ ();
2484 ffeste_emit_line_note_ ();
2486 /* Since ELSEIF(expr) might require preparations for expr,
2487 implement as ELSE; prepare-expr; IF (expr) THEN ...; ENDIF. */
2489 expand_start_else ();
2491 ffeste_start_block_ (block
);
2493 temp
= ffecom_make_tempvar ("elseif", integer_type_node
,
2494 FFETARGET_charactersizeNONE
, -1);
2496 ffeste_start_stmt_ ();
2498 ffecom_prepare_expr (expr
);
2500 if (ffecom_prepare_end ())
2504 result
= ffecom_modify (void_type_node
,
2506 ffecom_truth_value (ffecom_expr (expr
)));
2508 expand_expr_stmt (result
);
2510 ffeste_end_stmt_ ();
2514 /* In this case, we could probably have used expand_start_elseif
2515 instead, saving the need for a fake `else' construct. But,
2516 until it's clear that'd improve performance, it's easier this
2517 way, since we have to expand_start_else before we get to this
2518 test, given the current design. */
2520 ffeste_end_stmt_ ();
2522 temp
= ffecom_truth_value (ffecom_expr (expr
));
2525 expand_start_cond (temp
, 0);
2527 /* Increment number of fake `else' constructs introduced. */
2528 ffestw_set_ifthen_fake_else (block
,
2529 ffestw_ifthen_fake_else (block
) + 1);
2532 /* ELSE statement. */
2535 ffeste_R805 (ffestw block UNUSED
)
2537 ffeste_check_simple_ ();
2539 ffeste_emit_line_note_ ();
2541 expand_start_else ();
2544 /* END IF statement. */
2547 ffeste_R806 (ffestw block
)
2549 int i
= ffestw_ifthen_fake_else (block
) + 1;
2551 ffeste_emit_line_note_ ();
2557 ffeste_end_block_ (block
);
2561 /* Logical IF statement. */
2564 ffeste_R807 (ffebld expr
)
2568 ffeste_check_simple_ ();
2570 ffeste_emit_line_note_ ();
2572 ffeste_start_block_ (NULL
);
2574 temp
= ffecom_make_tempvar ("if", integer_type_node
,
2575 FFETARGET_charactersizeNONE
, -1);
2577 ffeste_start_stmt_ ();
2579 ffecom_prepare_expr (expr
);
2581 if (ffecom_prepare_end ())
2585 result
= ffecom_modify (void_type_node
,
2587 ffecom_truth_value (ffecom_expr (expr
)));
2589 expand_expr_stmt (result
);
2591 ffeste_end_stmt_ ();
2595 ffeste_end_stmt_ ();
2597 temp
= ffecom_truth_value (ffecom_expr (expr
));
2600 expand_start_cond (temp
, 0);
2603 /* SELECT CASE statement. */
2606 ffeste_R809 (ffestw block
, ffebld expr
)
2608 ffeste_check_simple_ ();
2610 ffeste_emit_line_note_ ();
2612 ffeste_start_block_ (block
);
2615 || (ffeinfo_basictype (ffebld_info (expr
))
2616 == FFEINFO_basictypeANY
))
2617 ffestw_set_select_texpr (block
, error_mark_node
);
2618 else if (ffeinfo_basictype (ffebld_info (expr
))
2619 == FFEINFO_basictypeCHARACTER
)
2621 /* ~~~Someday handle CHARACTER*1, CHARACTER*N */
2623 /* xgettext:no-c-format */
2624 ffebad_start_msg ("SELECT CASE on CHARACTER type (at %0) not supported -- sorry",
2625 FFEBAD_severityFATAL
);
2626 ffebad_here (0, ffestw_line (block
), ffestw_col (block
));
2628 ffestw_set_select_texpr (block
, error_mark_node
);
2635 result
= ffecom_make_tempvar ("select", ffecom_type_expr (expr
),
2636 ffeinfo_size (ffebld_info (expr
)),
2639 ffeste_start_stmt_ ();
2641 ffecom_prepare_expr (expr
);
2643 ffecom_prepare_end ();
2645 texpr
= ffecom_expr (expr
);
2647 assert (TYPE_MAIN_VARIANT (TREE_TYPE (texpr
))
2648 == TYPE_MAIN_VARIANT (TREE_TYPE (result
)));
2650 texpr
= ffecom_modify (void_type_node
,
2653 expand_expr_stmt (texpr
);
2655 ffeste_end_stmt_ ();
2657 expand_start_case (1, result
, TREE_TYPE (result
),
2658 "SELECT CASE statement");
2659 ffestw_set_select_texpr (block
, texpr
);
2660 ffestw_set_select_break (block
, FALSE
);
2666 If casenum is 0, it's CASE DEFAULT. Else it's the case ranges at
2667 the start of the first_stmt list in the select object at the top of
2668 the stack that match casenum. */
2671 ffeste_R810 (ffestw block
, unsigned long casenum
)
2673 ffestwSelect s
= ffestw_select (block
);
2681 ffeste_check_simple_ ();
2683 if (s
->first_stmt
== (ffestwCase
) &s
->first_rel
)
2688 ffeste_emit_line_note_ ();
2690 if (ffestw_select_texpr (block
) == error_mark_node
)
2693 /* ~~~Someday handle CHARACTER*1, CHARACTER*N */
2695 tlabel
= build_decl (LABEL_DECL
, NULL_TREE
, NULL_TREE
);
2697 if (ffestw_select_break (block
))
2698 expand_exit_something ();
2700 ffestw_set_select_break (block
, TRUE
);
2702 if ((c
== NULL
) || (casenum
!= c
->casenum
))
2704 if (casenum
== 0) /* Intentional CASE DEFAULT. */
2706 pushok
= pushcase (NULL_TREE
, 0, tlabel
, &duplicate
);
2707 assert (pushok
== 0);
2713 texprlow
= (c
->low
== NULL
) ? NULL_TREE
2714 : ffecom_constantunion_with_type (&ffebld_constant_union (c
->low
),
2715 ffecom_tree_type
[s
->type
][s
->kindtype
],c
->low
->consttype
);
2716 if (c
->low
!= c
->high
)
2718 texprhigh
= (c
->high
== NULL
) ? NULL_TREE
2719 : ffecom_constantunion_with_type (&ffebld_constant_union (c
->high
),
2720 ffecom_tree_type
[s
->type
][s
->kindtype
],c
->high
->consttype
);
2721 pushok
= pushcase_range (texprlow
, texprhigh
, convert
,
2722 tlabel
, &duplicate
);
2725 pushok
= pushcase (texprlow
, convert
, tlabel
, &duplicate
);
2728 ffebad_start_msg ("SELECT (at %0) has duplicate cases -- check integer overflow of CASE(s)",
2729 FFEBAD_severityFATAL
);
2730 ffebad_here (0, ffestw_line (block
), ffestw_col (block
));
2732 ffestw_set_select_texpr (block
, error_mark_node
);
2736 c
->previous_stmt
->previous_stmt
->next_stmt
= c
;
2737 c
->previous_stmt
= c
->previous_stmt
->previous_stmt
;
2739 while ((c
!= (ffestwCase
) &s
->first_rel
) && (casenum
== c
->casenum
));
2742 /* END SELECT statement. */
2745 ffeste_R811 (ffestw block
)
2747 ffeste_emit_line_note_ ();
2749 /* ~~~Someday handle CHARACTER*1, CHARACTER*N */
2751 if (TREE_CODE (ffestw_select_texpr (block
)) != ERROR_MARK
)
2752 expand_end_case (ffestw_select_texpr (block
));
2754 ffeste_end_block_ (block
);
2757 /* Iterative DO statement. */
2760 ffeste_R819A (ffestw block
, ffelab label UNUSED
, ffebld var
,
2761 ffebld start
, ffelexToken start_token
,
2762 ffebld end
, ffelexToken end_token
,
2763 ffebld incr
, ffelexToken incr_token
)
2765 ffeste_check_simple_ ();
2767 ffeste_emit_line_note_ ();
2769 ffeste_begin_iterdo_ (block
, NULL
, NULL
, NULL
,
2774 "Iterative DO loop");
2777 /* DO WHILE statement. */
2780 ffeste_R819B (ffestw block
, ffelab label UNUSED
, ffebld expr
)
2784 ffeste_check_simple_ ();
2786 ffeste_emit_line_note_ ();
2788 ffeste_start_block_ (block
);
2792 struct nesting
*loop
;
2795 result
= ffecom_make_tempvar ("dowhile", integer_type_node
,
2796 FFETARGET_charactersizeNONE
, -1);
2797 loop
= expand_start_loop (1);
2799 ffeste_start_stmt_ ();
2801 ffecom_prepare_expr (expr
);
2803 ffecom_prepare_end ();
2805 mod
= ffecom_modify (void_type_node
,
2807 ffecom_truth_value (ffecom_expr (expr
)));
2808 expand_expr_stmt (mod
);
2810 ffeste_end_stmt_ ();
2812 ffestw_set_do_hook (block
, loop
);
2813 expand_exit_loop_top_cond (0, result
);
2816 ffestw_set_do_hook (block
, expand_start_loop (1));
2818 ffestw_set_do_tvar (block
, NULL_TREE
);
2821 /* END DO statement.
2823 This is the MIL-STD 1753 END DO. It's syntactic sugar, similar to
2824 CONTINUE (except that it has to have a label that is the target of
2825 one or more iterative DO statement), not the Fortran-90 structured
2826 END DO, which is handled elsewhere, as is the actual mechanism of
2827 ending an iterative DO statement, even one that ends at a label. */
2832 ffeste_check_simple_ ();
2834 ffeste_emit_line_note_ ();
2839 /* CYCLE statement. */
2842 ffeste_R834 (ffestw block
)
2844 ffeste_check_simple_ ();
2846 ffeste_emit_line_note_ ();
2848 expand_continue_loop (ffestw_do_hook (block
));
2851 /* EXIT statement. */
2854 ffeste_R835 (ffestw block
)
2856 ffeste_check_simple_ ();
2858 ffeste_emit_line_note_ ();
2860 expand_exit_loop (ffestw_do_hook (block
));
2863 /* GOTO statement. */
2866 ffeste_R836 (ffelab label
)
2870 ffeste_check_simple_ ();
2872 ffeste_emit_line_note_ ();
2874 glabel
= ffecom_lookup_label (label
);
2875 if ((glabel
!= NULL_TREE
)
2876 && (TREE_CODE (glabel
) != ERROR_MARK
))
2878 expand_goto (glabel
);
2879 TREE_USED (glabel
) = 1;
2883 /* Computed GOTO statement. */
2886 ffeste_R837 (ffelab
*labels
, int count
, ffebld expr
)
2895 ffeste_check_simple_ ();
2897 ffeste_emit_line_note_ ();
2899 ffeste_start_stmt_ ();
2901 ffecom_prepare_expr (expr
);
2903 ffecom_prepare_end ();
2905 texpr
= ffecom_expr (expr
);
2907 expand_start_case (0, texpr
, TREE_TYPE (texpr
), "computed GOTO statement");
2909 for (i
= 0; i
< count
; ++i
)
2911 value
= build_int_2 (i
+ 1, 0);
2912 tlabel
= build_decl (LABEL_DECL
, NULL_TREE
, NULL_TREE
);
2914 pushok
= pushcase (value
, convert
, tlabel
, &duplicate
);
2915 assert (pushok
== 0);
2917 tlabel
= ffecom_lookup_label (labels
[i
]);
2918 if ((tlabel
== NULL_TREE
)
2919 || (TREE_CODE (tlabel
) == ERROR_MARK
))
2922 expand_goto (tlabel
);
2923 TREE_USED (tlabel
) = 1;
2925 expand_end_case (texpr
);
2927 ffeste_end_stmt_ ();
2930 /* ASSIGN statement. */
2933 ffeste_R838 (ffelab label
, ffebld target
)
2939 ffeste_check_simple_ ();
2941 ffeste_emit_line_note_ ();
2943 /* No need to call ffeste_start_stmt_(), as the sorts of expressions
2944 seen here should never require use of temporaries. */
2946 label_tree
= ffecom_lookup_label (label
);
2947 if ((label_tree
!= NULL_TREE
)
2948 && (TREE_CODE (label_tree
) != ERROR_MARK
))
2950 label_tree
= ffecom_1 (ADDR_EXPR
,
2951 build_pointer_type (void_type_node
),
2953 TREE_CONSTANT (label_tree
) = 1;
2955 target_tree
= ffecom_expr_assign_w (target
);
2956 if (GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (target_tree
)))
2957 < GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (label_tree
))))
2958 error ("ASSIGN to variable that is too small");
2960 label_tree
= convert (TREE_TYPE (target_tree
), label_tree
);
2962 expr_tree
= ffecom_modify (void_type_node
,
2965 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
);
2984 if (GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (t
)))
2985 < GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node
))))
2986 error ("ASSIGNed GOTO target variable is too small");
2988 expand_computed_goto (convert (TREE_TYPE (null_pointer_node
), t
));
2991 /* Arithmetic IF statement. */
2994 ffeste_R840 (ffebld expr
, ffelab neg
, ffelab zero
, ffelab pos
)
2996 tree gneg
= ffecom_lookup_label (neg
);
2997 tree gzero
= ffecom_lookup_label (zero
);
2998 tree gpos
= ffecom_lookup_label (pos
);
3001 ffeste_check_simple_ ();
3003 ffeste_emit_line_note_ ();
3005 if ((gneg
== NULL_TREE
) || (gzero
== NULL_TREE
) || (gpos
== NULL_TREE
))
3007 if ((TREE_CODE (gneg
) == ERROR_MARK
)
3008 || (TREE_CODE (gzero
) == ERROR_MARK
)
3009 || (TREE_CODE (gpos
) == ERROR_MARK
))
3012 ffeste_start_stmt_ ();
3014 ffecom_prepare_expr (expr
);
3016 ffecom_prepare_end ();
3021 expand_goto (gzero
);
3024 /* IF (expr.LE.0) THEN GOTO neg/zero ELSE GOTO pos. */
3025 texpr
= ffecom_expr (expr
);
3026 texpr
= ffecom_2 (LE_EXPR
, integer_type_node
,
3028 convert (TREE_TYPE (texpr
),
3029 integer_zero_node
));
3030 expand_start_cond (ffecom_truth_value (texpr
), 0);
3031 expand_goto (gzero
);
3032 expand_start_else ();
3037 else if (neg
== pos
)
3039 /* IF (expr.NE.0) THEN GOTO neg/pos ELSE GOTO zero. */
3040 texpr
= ffecom_expr (expr
);
3041 texpr
= ffecom_2 (NE_EXPR
, integer_type_node
,
3043 convert (TREE_TYPE (texpr
),
3044 integer_zero_node
));
3045 expand_start_cond (ffecom_truth_value (texpr
), 0);
3047 expand_start_else ();
3048 expand_goto (gzero
);
3051 else if (zero
== pos
)
3053 /* IF (expr.GE.0) THEN GOTO zero/pos ELSE GOTO neg. */
3054 texpr
= ffecom_expr (expr
);
3055 texpr
= ffecom_2 (GE_EXPR
, integer_type_node
,
3057 convert (TREE_TYPE (texpr
),
3058 integer_zero_node
));
3059 expand_start_cond (ffecom_truth_value (texpr
), 0);
3060 expand_goto (gzero
);
3061 expand_start_else ();
3067 /* Use a SAVE_EXPR in combo with:
3068 IF (expr.LT.0) THEN GOTO neg
3069 ELSEIF (expr.GT.0) THEN GOTO pos
3071 tree expr_saved
= ffecom_save_tree (ffecom_expr (expr
));
3073 texpr
= ffecom_2 (LT_EXPR
, integer_type_node
,
3075 convert (TREE_TYPE (expr_saved
),
3076 integer_zero_node
));
3077 expand_start_cond (ffecom_truth_value (texpr
), 0);
3079 texpr
= ffecom_2 (GT_EXPR
, integer_type_node
,
3081 convert (TREE_TYPE (expr_saved
),
3082 integer_zero_node
));
3083 expand_start_elseif (ffecom_truth_value (texpr
));
3085 expand_start_else ();
3086 expand_goto (gzero
);
3090 ffeste_end_stmt_ ();
3093 /* CONTINUE statement. */
3098 ffeste_check_simple_ ();
3100 ffeste_emit_line_note_ ();
3105 /* STOP statement. */
3108 ffeste_R842 (ffebld expr
)
3113 ffeste_check_simple_ ();
3115 ffeste_emit_line_note_ ();
3118 || (ffeinfo_basictype (ffebld_info (expr
))
3119 == FFEINFO_basictypeANY
))
3121 msg
= ffelex_token_new_character ("",
3122 ffelex_token_where_line (ffesta_tokens
[0]),
3123 ffelex_token_where_column (ffesta_tokens
[0]));
3124 expr
= ffebld_new_conter (ffebld_constant_new_characterdefault
3126 ffelex_token_kill (msg
);
3127 ffebld_set_info (expr
, ffeinfo_new (FFEINFO_basictypeCHARACTER
,
3128 FFEINFO_kindtypeCHARACTERDEFAULT
,
3129 0, FFEINFO_kindENTITY
,
3130 FFEINFO_whereCONSTANT
, 0));
3132 else if (ffeinfo_basictype (ffebld_info (expr
))
3133 == FFEINFO_basictypeINTEGER
)
3137 assert (ffebld_op (expr
) == FFEBLD_opCONTER
);
3138 assert (ffeinfo_kindtype (ffebld_info (expr
))
3139 == FFEINFO_kindtypeINTEGERDEFAULT
);
3140 sprintf (num
, "%" ffetargetIntegerDefault_f
"d",
3141 ffebld_constant_integer1 (ffebld_conter (expr
)));
3142 msg
= ffelex_token_new_character (num
,
3143 ffelex_token_where_line (ffesta_tokens
[0]),
3144 ffelex_token_where_column (ffesta_tokens
[0]));
3145 expr
= ffebld_new_conter (ffebld_constant_new_characterdefault (msg
));
3146 ffelex_token_kill (msg
);
3147 ffebld_set_info (expr
, ffeinfo_new (FFEINFO_basictypeCHARACTER
,
3148 FFEINFO_kindtypeCHARACTERDEFAULT
,
3149 0, FFEINFO_kindENTITY
,
3150 FFEINFO_whereCONSTANT
, 0));
3154 assert (ffeinfo_basictype (ffebld_info (expr
))
3155 == FFEINFO_basictypeCHARACTER
);
3156 assert (ffebld_op (expr
) == FFEBLD_opCONTER
);
3157 assert (ffeinfo_kindtype (ffebld_info (expr
))
3158 == FFEINFO_kindtypeCHARACTERDEFAULT
);
3161 /* No need to call ffeste_start_stmt_(), as the sorts of expressions
3162 seen here should never require use of temporaries. */
3164 callit
= ffecom_call_gfrt (FFECOM_gfrtSTOP
,
3165 ffecom_list_ptr_to_expr (ffebld_new_item (expr
, NULL
)),
3167 TREE_SIDE_EFFECTS (callit
) = 1;
3169 expand_expr_stmt (callit
);
3172 /* PAUSE statement. */
3175 ffeste_R843 (ffebld expr
)
3180 ffeste_check_simple_ ();
3182 ffeste_emit_line_note_ ();
3185 || (ffeinfo_basictype (ffebld_info (expr
))
3186 == FFEINFO_basictypeANY
))
3188 msg
= ffelex_token_new_character ("",
3189 ffelex_token_where_line (ffesta_tokens
[0]),
3190 ffelex_token_where_column (ffesta_tokens
[0]));
3191 expr
= ffebld_new_conter (ffebld_constant_new_characterdefault (msg
));
3192 ffelex_token_kill (msg
);
3193 ffebld_set_info (expr
, ffeinfo_new (FFEINFO_basictypeCHARACTER
,
3194 FFEINFO_kindtypeCHARACTERDEFAULT
,
3195 0, FFEINFO_kindENTITY
,
3196 FFEINFO_whereCONSTANT
, 0));
3198 else if (ffeinfo_basictype (ffebld_info (expr
)) == FFEINFO_basictypeINTEGER
)
3202 assert (ffebld_op (expr
) == FFEBLD_opCONTER
);
3203 assert (ffeinfo_kindtype (ffebld_info (expr
))
3204 == FFEINFO_kindtypeINTEGERDEFAULT
);
3205 sprintf (num
, "%" ffetargetIntegerDefault_f
"d",
3206 ffebld_constant_integer1 (ffebld_conter (expr
)));
3207 msg
= ffelex_token_new_character (num
, ffelex_token_where_line (ffesta_tokens
[0]),
3208 ffelex_token_where_column (ffesta_tokens
[0]));
3209 expr
= ffebld_new_conter (ffebld_constant_new_characterdefault (msg
));
3210 ffelex_token_kill (msg
);
3211 ffebld_set_info (expr
, ffeinfo_new (FFEINFO_basictypeCHARACTER
,
3212 FFEINFO_kindtypeCHARACTERDEFAULT
,
3213 0, FFEINFO_kindENTITY
,
3214 FFEINFO_whereCONSTANT
, 0));
3218 assert (ffeinfo_basictype (ffebld_info (expr
))
3219 == FFEINFO_basictypeCHARACTER
);
3220 assert (ffebld_op (expr
) == FFEBLD_opCONTER
);
3221 assert (ffeinfo_kindtype (ffebld_info (expr
))
3222 == FFEINFO_kindtypeCHARACTERDEFAULT
);
3225 /* No need to call ffeste_start_stmt_(), as the sorts of expressions
3226 seen here should never require use of temporaries. */
3228 callit
= ffecom_call_gfrt (FFECOM_gfrtPAUSE
,
3229 ffecom_list_ptr_to_expr (ffebld_new_item (expr
, NULL
)),
3231 TREE_SIDE_EFFECTS (callit
) = 1;
3233 expand_expr_stmt (callit
);
3236 /* OPEN statement. */
3239 ffeste_R904 (ffestpOpenStmt
*info
)
3245 ffeste_check_simple_ ();
3247 ffeste_emit_line_note_ ();
3249 #define specified(something) (info->open_spec[something].kw_or_val_present)
3251 iostat
= specified (FFESTP_openixIOSTAT
);
3252 errl
= specified (FFESTP_openixERR
);
3256 ffeste_start_stmt_ ();
3262 = ffecom_lookup_label
3263 (info
->open_spec
[FFESTP_openixERR
].u
.label
);
3264 ffeste_io_abort_is_temp_
= FALSE
;
3268 ffeste_io_err_
= NULL_TREE
;
3270 if ((ffeste_io_abort_is_temp_
= iostat
))
3271 ffeste_io_abort_
= ffecom_temp_label ();
3273 ffeste_io_abort_
= NULL_TREE
;
3278 /* Have IOSTAT= specification. */
3280 ffeste_io_iostat_is_temp_
= FALSE
;
3281 ffeste_io_iostat_
= ffecom_expr
3282 (info
->open_spec
[FFESTP_openixIOSTAT
].u
.expr
);
3284 else if (ffeste_io_abort_
!= NULL_TREE
)
3286 /* Have no IOSTAT= but have ERR=. */
3288 ffeste_io_iostat_is_temp_
= TRUE
;
3290 = ffecom_make_tempvar ("open", ffecom_integer_type_node
,
3291 FFETARGET_charactersizeNONE
, -1);
3295 /* No IOSTAT= or ERR= specification. */
3297 ffeste_io_iostat_is_temp_
= FALSE
;
3298 ffeste_io_iostat_
= NULL_TREE
;
3301 /* Now prescan, then convert, all the arguments. */
3303 args
= ffeste_io_olist_ (errl
|| iostat
,
3304 info
->open_spec
[FFESTP_openixUNIT
].u
.expr
,
3305 &info
->open_spec
[FFESTP_openixFILE
],
3306 &info
->open_spec
[FFESTP_openixSTATUS
],
3307 &info
->open_spec
[FFESTP_openixACCESS
],
3308 &info
->open_spec
[FFESTP_openixFORM
],
3309 &info
->open_spec
[FFESTP_openixRECL
],
3310 &info
->open_spec
[FFESTP_openixBLANK
]);
3312 /* Don't generate "if (iostat != 0) goto label;" if label is temp abort
3313 label, since we're gonna fall through to there anyway. */
3315 ffeste_io_call_ (ffecom_call_gfrt (FFECOM_gfrtFOPEN
, args
, NULL_TREE
),
3316 ! ffeste_io_abort_is_temp_
);
3318 /* If we've got a temp label, generate its code here. */
3320 if (ffeste_io_abort_is_temp_
)
3322 DECL_INITIAL (ffeste_io_abort_
) = error_mark_node
;
3324 expand_label (ffeste_io_abort_
);
3326 assert (ffeste_io_err_
== NULL_TREE
);
3329 ffeste_end_stmt_ ();
3332 /* CLOSE statement. */
3335 ffeste_R907 (ffestpCloseStmt
*info
)
3341 ffeste_check_simple_ ();
3343 ffeste_emit_line_note_ ();
3345 #define specified(something) (info->close_spec[something].kw_or_val_present)
3347 iostat
= specified (FFESTP_closeixIOSTAT
);
3348 errl
= specified (FFESTP_closeixERR
);
3352 ffeste_start_stmt_ ();
3358 = ffecom_lookup_label
3359 (info
->close_spec
[FFESTP_closeixERR
].u
.label
);
3360 ffeste_io_abort_is_temp_
= FALSE
;
3364 ffeste_io_err_
= NULL_TREE
;
3366 if ((ffeste_io_abort_is_temp_
= iostat
))
3367 ffeste_io_abort_
= ffecom_temp_label ();
3369 ffeste_io_abort_
= NULL_TREE
;
3374 /* Have IOSTAT= specification. */
3376 ffeste_io_iostat_is_temp_
= FALSE
;
3377 ffeste_io_iostat_
= ffecom_expr
3378 (info
->close_spec
[FFESTP_closeixIOSTAT
].u
.expr
);
3380 else if (ffeste_io_abort_
!= NULL_TREE
)
3382 /* Have no IOSTAT= but have ERR=. */
3384 ffeste_io_iostat_is_temp_
= TRUE
;
3386 = ffecom_make_tempvar ("close", ffecom_integer_type_node
,
3387 FFETARGET_charactersizeNONE
, -1);
3391 /* No IOSTAT= or ERR= specification. */
3393 ffeste_io_iostat_is_temp_
= FALSE
;
3394 ffeste_io_iostat_
= NULL_TREE
;
3397 /* Now prescan, then convert, all the arguments. */
3399 args
= ffeste_io_cllist_ (errl
|| iostat
,
3400 info
->close_spec
[FFESTP_closeixUNIT
].u
.expr
,
3401 &info
->close_spec
[FFESTP_closeixSTATUS
]);
3403 /* Don't generate "if (iostat != 0) goto label;" if label is temp abort
3404 label, since we're gonna fall through to there anyway. */
3406 ffeste_io_call_ (ffecom_call_gfrt (FFECOM_gfrtFCLOS
, args
, NULL_TREE
),
3407 ! ffeste_io_abort_is_temp_
);
3409 /* If we've got a temp label, generate its code here. */
3411 if (ffeste_io_abort_is_temp_
)
3413 DECL_INITIAL (ffeste_io_abort_
) = error_mark_node
;
3415 expand_label (ffeste_io_abort_
);
3417 assert (ffeste_io_err_
== NULL_TREE
);
3420 ffeste_end_stmt_ ();
3423 /* READ(...) statement -- start. */
3426 ffeste_R909_start (ffestpReadStmt
*info
, bool only_format UNUSED
,
3427 ffestvUnit unit
, ffestvFormat format
, bool rec
,
3437 ffeste_check_start_ ();
3439 ffeste_emit_line_note_ ();
3441 /* First determine the start, per-item, and end run-time functions to
3442 call. The per-item function is picked by choosing an ffeste function
3443 to call to handle a given item; it knows how to generate a call to the
3444 appropriate run-time function, and is called an "I/O driver". */
3448 case FFESTV_formatNONE
: /* no FMT= */
3449 ffeste_io_driver_
= ffeste_io_douio_
;
3451 start
= FFECOM_gfrtSRDUE
, end
= FFECOM_gfrtERDUE
;
3453 start
= FFECOM_gfrtSRSUE
, end
= FFECOM_gfrtERSUE
;
3456 case FFESTV_formatLABEL
: /* FMT=10 */
3457 case FFESTV_formatCHAREXPR
: /* FMT='(I10)' */
3458 case FFESTV_formatINTEXPR
: /* FMT=I [after ASSIGN 10 TO I] */
3459 ffeste_io_driver_
= ffeste_io_dofio_
;
3461 start
= FFECOM_gfrtSRDFE
, end
= FFECOM_gfrtERDFE
;
3462 else if (unit
== FFESTV_unitCHAREXPR
)
3463 start
= FFECOM_gfrtSRSFI
, end
= FFECOM_gfrtERSFI
;
3465 start
= FFECOM_gfrtSRSFE
, end
= FFECOM_gfrtERSFE
;
3468 case FFESTV_formatASTERISK
: /* FMT=* */
3469 ffeste_io_driver_
= ffeste_io_dolio_
;
3470 if (unit
== FFESTV_unitCHAREXPR
)
3471 start
= FFECOM_gfrtSRSLI
, end
= FFECOM_gfrtERSLI
;
3473 start
= FFECOM_gfrtSRSLE
, end
= FFECOM_gfrtERSLE
;
3476 case FFESTV_formatNAMELIST
: /* FMT=FOO or NML=FOO [NAMELIST
3478 ffeste_io_driver_
= NULL
; /* No start or driver function. */
3479 start
= FFECOM_gfrtSRSNE
, end
= FFECOM_gfrt
;
3483 assert ("Weird stuff" == NULL
);
3484 start
= FFECOM_gfrt
, end
= FFECOM_gfrt
;
3487 ffeste_io_endgfrt_
= end
;
3489 #define specified(something) (info->read_spec[something].kw_or_val_present)
3491 iostat
= specified (FFESTP_readixIOSTAT
);
3492 errl
= specified (FFESTP_readixERR
);
3493 endl
= specified (FFESTP_readixEND
);
3497 ffeste_start_stmt_ ();
3501 /* Have ERR= specification. */
3504 = ffecom_lookup_label (info
->read_spec
[FFESTP_readixERR
].u
.label
);
3508 /* Have both ERR= and END=. Need a temp label to handle both. */
3510 = ffecom_lookup_label (info
->read_spec
[FFESTP_readixEND
].u
.label
);
3511 ffeste_io_abort_is_temp_
= TRUE
;
3512 ffeste_io_abort_
= ffecom_temp_label ();
3516 /* Have ERR= but no END=. */
3517 ffeste_io_end_
= NULL_TREE
;
3518 if ((ffeste_io_abort_is_temp_
= iostat
))
3519 ffeste_io_abort_
= ffecom_temp_label ();
3521 ffeste_io_abort_
= ffeste_io_err_
;
3526 /* No ERR= specification. */
3528 ffeste_io_err_
= NULL_TREE
;
3531 /* Have END= but no ERR=. */
3533 = ffecom_lookup_label (info
->read_spec
[FFESTP_readixEND
].u
.label
);
3534 if ((ffeste_io_abort_is_temp_
= iostat
))
3535 ffeste_io_abort_
= ffecom_temp_label ();
3537 ffeste_io_abort_
= ffeste_io_end_
;
3541 /* Have no ERR= or END=. */
3543 ffeste_io_end_
= NULL_TREE
;
3544 if ((ffeste_io_abort_is_temp_
= iostat
))
3545 ffeste_io_abort_
= ffecom_temp_label ();
3547 ffeste_io_abort_
= NULL_TREE
;
3553 /* Have IOSTAT= specification. */
3555 ffeste_io_iostat_is_temp_
= FALSE
;
3557 = ffecom_expr (info
->read_spec
[FFESTP_readixIOSTAT
].u
.expr
);
3559 else if (ffeste_io_abort_
!= NULL_TREE
)
3561 /* Have no IOSTAT= but have ERR= and/or END=. */
3563 ffeste_io_iostat_is_temp_
= TRUE
;
3565 = ffecom_make_tempvar ("read", ffecom_integer_type_node
,
3566 FFETARGET_charactersizeNONE
, -1);
3570 /* No IOSTAT=, ERR=, or END= specification. */
3572 ffeste_io_iostat_is_temp_
= FALSE
;
3573 ffeste_io_iostat_
= NULL_TREE
;
3576 /* Now prescan, then convert, all the arguments. */
3578 if (unit
== FFESTV_unitCHAREXPR
)
3579 cilist
= ffeste_io_icilist_ (errl
|| iostat
,
3580 info
->read_spec
[FFESTP_readixUNIT
].u
.expr
,
3581 endl
|| iostat
, format
,
3582 &info
->read_spec
[FFESTP_readixFORMAT
]);
3584 cilist
= ffeste_io_cilist_ (errl
|| iostat
, unit
,
3585 info
->read_spec
[FFESTP_readixUNIT
].u
.expr
,
3586 5, endl
|| iostat
, format
,
3587 &info
->read_spec
[FFESTP_readixFORMAT
],
3589 info
->read_spec
[FFESTP_readixREC
].u
.expr
);
3591 /* If there is no end function, then there are no item functions (i.e.
3592 it's a NAMELIST), and vice versa by the way. In this situation, don't
3593 generate the "if (iostat != 0) goto label;" if the label is temp abort
3594 label, since we're gonna fall through to there anyway. */
3596 ffeste_io_call_ (ffecom_call_gfrt (start
, cilist
, NULL_TREE
),
3597 (! ffeste_io_abort_is_temp_
) || (end
!= FFECOM_gfrt
));
3600 /* READ statement -- I/O item. */
3603 ffeste_R909_item (ffebld expr
, ffelexToken expr_token
)
3605 ffeste_check_item_ ();
3610 /* Strip parens off items such as in "READ *,(A)". This is really a bug
3611 in the user's code, but I've been told lots of code does this. */
3612 while (ffebld_op (expr
) == FFEBLD_opPAREN
)
3613 expr
= ffebld_left (expr
);
3615 if (ffebld_op (expr
) == FFEBLD_opANY
)
3618 if (ffebld_op (expr
) == FFEBLD_opIMPDO
)
3619 ffeste_io_impdo_ (expr
, expr_token
);
3622 ffeste_start_stmt_ ();
3624 ffecom_prepare_arg_ptr_to_expr (expr
);
3626 ffecom_prepare_end ();
3628 ffeste_io_call_ ((*ffeste_io_driver_
) (expr
), TRUE
);
3630 ffeste_end_stmt_ ();
3634 /* READ statement -- end. */
3637 ffeste_R909_finish ()
3639 ffeste_check_finish_ ();
3641 /* Don't generate "if (iostat != 0) goto label;" if label is temp abort
3642 label, since we're gonna fall through to there anyway. */
3644 if (ffeste_io_endgfrt_
!= FFECOM_gfrt
)
3645 ffeste_io_call_ (ffecom_call_gfrt (ffeste_io_endgfrt_
, NULL_TREE
,
3647 ! ffeste_io_abort_is_temp_
);
3649 /* If we've got a temp label, generate its code here and have it fan out
3650 to the END= or ERR= label as appropriate. */
3652 if (ffeste_io_abort_is_temp_
)
3654 DECL_INITIAL (ffeste_io_abort_
) = error_mark_node
;
3656 expand_label (ffeste_io_abort_
);
3658 /* "if (iostat<0) goto end_label;". */
3660 if ((ffeste_io_end_
!= NULL_TREE
)
3661 && (TREE_CODE (ffeste_io_end_
) != ERROR_MARK
))
3663 expand_start_cond (ffecom_truth_value
3664 (ffecom_2 (LT_EXPR
, integer_type_node
,
3666 ffecom_integer_zero_node
)),
3668 expand_goto (ffeste_io_end_
);
3672 /* "if (iostat>0) goto err_label;". */
3674 if ((ffeste_io_err_
!= NULL_TREE
)
3675 && (TREE_CODE (ffeste_io_err_
) != ERROR_MARK
))
3677 expand_start_cond (ffecom_truth_value
3678 (ffecom_2 (GT_EXPR
, integer_type_node
,
3680 ffecom_integer_zero_node
)),
3682 expand_goto (ffeste_io_err_
);
3687 ffeste_end_stmt_ ();
3690 /* WRITE statement -- start. */
3693 ffeste_R910_start (ffestpWriteStmt
*info
, ffestvUnit unit
,
3694 ffestvFormat format
, bool rec
)
3702 ffeste_check_start_ ();
3704 ffeste_emit_line_note_ ();
3706 /* First determine the start, per-item, and end run-time functions to
3707 call. The per-item function is picked by choosing an ffeste function
3708 to call to handle a given item; it knows how to generate a call to the
3709 appropriate run-time function, and is called an "I/O driver". */
3713 case FFESTV_formatNONE
: /* no FMT= */
3714 ffeste_io_driver_
= ffeste_io_douio_
;
3716 start
= FFECOM_gfrtSWDUE
, end
= FFECOM_gfrtEWDUE
;
3718 start
= FFECOM_gfrtSWSUE
, end
= FFECOM_gfrtEWSUE
;
3721 case FFESTV_formatLABEL
: /* FMT=10 */
3722 case FFESTV_formatCHAREXPR
: /* FMT='(I10)' */
3723 case FFESTV_formatINTEXPR
: /* FMT=I [after ASSIGN 10 TO I] */
3724 ffeste_io_driver_
= ffeste_io_dofio_
;
3726 start
= FFECOM_gfrtSWDFE
, end
= FFECOM_gfrtEWDFE
;
3727 else if (unit
== FFESTV_unitCHAREXPR
)
3728 start
= FFECOM_gfrtSWSFI
, end
= FFECOM_gfrtEWSFI
;
3730 start
= FFECOM_gfrtSWSFE
, end
= FFECOM_gfrtEWSFE
;
3733 case FFESTV_formatASTERISK
: /* FMT=* */
3734 ffeste_io_driver_
= ffeste_io_dolio_
;
3735 if (unit
== FFESTV_unitCHAREXPR
)
3736 start
= FFECOM_gfrtSWSLI
, end
= FFECOM_gfrtEWSLI
;
3738 start
= FFECOM_gfrtSWSLE
, end
= FFECOM_gfrtEWSLE
;
3741 case FFESTV_formatNAMELIST
: /* FMT=FOO or NML=FOO [NAMELIST
3743 ffeste_io_driver_
= NULL
; /* No start or driver function. */
3744 start
= FFECOM_gfrtSWSNE
, end
= FFECOM_gfrt
;
3748 assert ("Weird stuff" == NULL
);
3749 start
= FFECOM_gfrt
, end
= FFECOM_gfrt
;
3752 ffeste_io_endgfrt_
= end
;
3754 #define specified(something) (info->write_spec[something].kw_or_val_present)
3756 iostat
= specified (FFESTP_writeixIOSTAT
);
3757 errl
= specified (FFESTP_writeixERR
);
3761 ffeste_start_stmt_ ();
3763 ffeste_io_end_
= NULL_TREE
;
3767 /* Have ERR= specification. */
3771 = ffecom_lookup_label
3772 (info
->write_spec
[FFESTP_writeixERR
].u
.label
);
3773 ffeste_io_abort_is_temp_
= FALSE
;
3777 /* No ERR= specification. */
3779 ffeste_io_err_
= NULL_TREE
;
3781 if ((ffeste_io_abort_is_temp_
= iostat
))
3782 ffeste_io_abort_
= ffecom_temp_label ();
3784 ffeste_io_abort_
= NULL_TREE
;
3789 /* Have IOSTAT= specification. */
3791 ffeste_io_iostat_is_temp_
= FALSE
;
3792 ffeste_io_iostat_
= ffecom_expr
3793 (info
->write_spec
[FFESTP_writeixIOSTAT
].u
.expr
);
3795 else if (ffeste_io_abort_
!= NULL_TREE
)
3797 /* Have no IOSTAT= but have ERR=. */
3799 ffeste_io_iostat_is_temp_
= TRUE
;
3801 = ffecom_make_tempvar ("write", ffecom_integer_type_node
,
3802 FFETARGET_charactersizeNONE
, -1);
3806 /* No IOSTAT= or ERR= specification. */
3808 ffeste_io_iostat_is_temp_
= FALSE
;
3809 ffeste_io_iostat_
= NULL_TREE
;
3812 /* Now prescan, then convert, all the arguments. */
3814 if (unit
== FFESTV_unitCHAREXPR
)
3815 cilist
= ffeste_io_icilist_ (errl
|| iostat
,
3816 info
->write_spec
[FFESTP_writeixUNIT
].u
.expr
,
3818 &info
->write_spec
[FFESTP_writeixFORMAT
]);
3820 cilist
= ffeste_io_cilist_ (errl
|| iostat
, unit
,
3821 info
->write_spec
[FFESTP_writeixUNIT
].u
.expr
,
3823 &info
->write_spec
[FFESTP_writeixFORMAT
],
3825 info
->write_spec
[FFESTP_writeixREC
].u
.expr
);
3827 /* If there is no end function, then there are no item functions (i.e.
3828 it's a NAMELIST), and vice versa by the way. In this situation, don't
3829 generate the "if (iostat != 0) goto label;" if the label is temp abort
3830 label, since we're gonna fall through to there anyway. */
3832 ffeste_io_call_ (ffecom_call_gfrt (start
, cilist
, NULL_TREE
),
3833 (! ffeste_io_abort_is_temp_
) || (end
!= FFECOM_gfrt
));
3836 /* WRITE statement -- I/O item. */
3839 ffeste_R910_item (ffebld expr
, ffelexToken expr_token
)
3841 ffeste_check_item_ ();
3846 if (ffebld_op (expr
) == FFEBLD_opANY
)
3849 if (ffebld_op (expr
) == FFEBLD_opIMPDO
)
3850 ffeste_io_impdo_ (expr
, expr_token
);
3853 ffeste_start_stmt_ ();
3855 ffecom_prepare_arg_ptr_to_expr (expr
);
3857 ffecom_prepare_end ();
3859 ffeste_io_call_ ((*ffeste_io_driver_
) (expr
), TRUE
);
3861 ffeste_end_stmt_ ();
3865 /* WRITE statement -- end. */
3868 ffeste_R910_finish ()
3870 ffeste_check_finish_ ();
3872 /* Don't generate "if (iostat != 0) goto label;" if label is temp abort
3873 label, since we're gonna fall through to there anyway. */
3875 if (ffeste_io_endgfrt_
!= FFECOM_gfrt
)
3876 ffeste_io_call_ (ffecom_call_gfrt (ffeste_io_endgfrt_
, NULL_TREE
,
3878 ! ffeste_io_abort_is_temp_
);
3880 /* If we've got a temp label, generate its code here. */
3882 if (ffeste_io_abort_is_temp_
)
3884 DECL_INITIAL (ffeste_io_abort_
) = error_mark_node
;
3886 expand_label (ffeste_io_abort_
);
3888 assert (ffeste_io_err_
== NULL_TREE
);
3891 ffeste_end_stmt_ ();
3894 /* PRINT statement -- start. */
3897 ffeste_R911_start (ffestpPrintStmt
*info
, ffestvFormat format
)
3903 ffeste_check_start_ ();
3905 ffeste_emit_line_note_ ();
3907 /* First determine the start, per-item, and end run-time functions to
3908 call. The per-item function is picked by choosing an ffeste function
3909 to call to handle a given item; it knows how to generate a call to the
3910 appropriate run-time function, and is called an "I/O driver". */
3914 case FFESTV_formatLABEL
: /* FMT=10 */
3915 case FFESTV_formatCHAREXPR
: /* FMT='(I10)' */
3916 case FFESTV_formatINTEXPR
: /* FMT=I [after ASSIGN 10 TO I] */
3917 ffeste_io_driver_
= ffeste_io_dofio_
;
3918 start
= FFECOM_gfrtSWSFE
, end
= FFECOM_gfrtEWSFE
;
3921 case FFESTV_formatASTERISK
: /* FMT=* */
3922 ffeste_io_driver_
= ffeste_io_dolio_
;
3923 start
= FFECOM_gfrtSWSLE
, end
= FFECOM_gfrtEWSLE
;
3926 case FFESTV_formatNAMELIST
: /* FMT=FOO or NML=FOO [NAMELIST
3928 ffeste_io_driver_
= NULL
; /* No start or driver function. */
3929 start
= FFECOM_gfrtSWSNE
, end
= FFECOM_gfrt
;
3933 assert ("Weird stuff" == NULL
);
3934 start
= FFECOM_gfrt
, end
= FFECOM_gfrt
;
3937 ffeste_io_endgfrt_
= end
;
3939 ffeste_start_stmt_ ();
3941 ffeste_io_end_
= NULL_TREE
;
3942 ffeste_io_err_
= NULL_TREE
;
3943 ffeste_io_abort_
= NULL_TREE
;
3944 ffeste_io_abort_is_temp_
= FALSE
;
3945 ffeste_io_iostat_is_temp_
= FALSE
;
3946 ffeste_io_iostat_
= NULL_TREE
;
3948 /* Now prescan, then convert, all the arguments. */
3950 cilist
= ffeste_io_cilist_ (FALSE
, FFESTV_unitNONE
, NULL
, 6, FALSE
, format
,
3951 &info
->print_spec
[FFESTP_printixFORMAT
],
3954 /* If there is no end function, then there are no item functions (i.e.
3955 it's a NAMELIST), and vice versa by the way. In this situation, don't
3956 generate the "if (iostat != 0) goto label;" if the label is temp abort
3957 label, since we're gonna fall through to there anyway. */
3959 ffeste_io_call_ (ffecom_call_gfrt (start
, cilist
, NULL_TREE
),
3960 (! ffeste_io_abort_is_temp_
) || (end
!= FFECOM_gfrt
));
3963 /* PRINT statement -- I/O item. */
3966 ffeste_R911_item (ffebld expr
, ffelexToken expr_token
)
3968 ffeste_check_item_ ();
3973 if (ffebld_op (expr
) == FFEBLD_opANY
)
3976 if (ffebld_op (expr
) == FFEBLD_opIMPDO
)
3977 ffeste_io_impdo_ (expr
, expr_token
);
3980 ffeste_start_stmt_ ();
3982 ffecom_prepare_arg_ptr_to_expr (expr
);
3984 ffecom_prepare_end ();
3986 ffeste_io_call_ ((*ffeste_io_driver_
) (expr
), TRUE
);
3988 ffeste_end_stmt_ ();
3992 /* PRINT statement -- end. */
3995 ffeste_R911_finish ()
3997 ffeste_check_finish_ ();
3999 if (ffeste_io_endgfrt_
!= FFECOM_gfrt
)
4000 ffeste_io_call_ (ffecom_call_gfrt (ffeste_io_endgfrt_
, NULL_TREE
,
4004 ffeste_end_stmt_ ();
4007 /* BACKSPACE statement. */
4010 ffeste_R919 (ffestpBeruStmt
*info
)
4012 ffeste_check_simple_ ();
4014 ffeste_subr_beru_ (info
, FFECOM_gfrtFBACK
);
4017 /* ENDFILE statement. */
4020 ffeste_R920 (ffestpBeruStmt
*info
)
4022 ffeste_check_simple_ ();
4024 ffeste_subr_beru_ (info
, FFECOM_gfrtFEND
);
4027 /* REWIND statement. */
4030 ffeste_R921 (ffestpBeruStmt
*info
)
4032 ffeste_check_simple_ ();
4034 ffeste_subr_beru_ (info
, FFECOM_gfrtFREW
);
4037 /* INQUIRE statement (non-IOLENGTH version). */
4040 ffeste_R923A (ffestpInquireStmt
*info
, bool by_file UNUSED
)
4046 ffeste_check_simple_ ();
4048 ffeste_emit_line_note_ ();
4050 #define specified(something) (info->inquire_spec[something].kw_or_val_present)
4052 iostat
= specified (FFESTP_inquireixIOSTAT
);
4053 errl
= specified (FFESTP_inquireixERR
);
4057 ffeste_start_stmt_ ();
4063 = ffecom_lookup_label
4064 (info
->inquire_spec
[FFESTP_inquireixERR
].u
.label
);
4065 ffeste_io_abort_is_temp_
= FALSE
;
4069 ffeste_io_err_
= NULL_TREE
;
4071 if ((ffeste_io_abort_is_temp_
= iostat
))
4072 ffeste_io_abort_
= ffecom_temp_label ();
4074 ffeste_io_abort_
= NULL_TREE
;
4079 /* Have IOSTAT= specification. */
4081 ffeste_io_iostat_is_temp_
= FALSE
;
4082 ffeste_io_iostat_
= ffecom_expr
4083 (info
->inquire_spec
[FFESTP_inquireixIOSTAT
].u
.expr
);
4085 else if (ffeste_io_abort_
!= NULL_TREE
)
4087 /* Have no IOSTAT= but have ERR=. */
4089 ffeste_io_iostat_is_temp_
= TRUE
;
4091 = ffecom_make_tempvar ("inquire", ffecom_integer_type_node
,
4092 FFETARGET_charactersizeNONE
, -1);
4096 /* No IOSTAT= or ERR= specification. */
4098 ffeste_io_iostat_is_temp_
= FALSE
;
4099 ffeste_io_iostat_
= NULL_TREE
;
4102 /* Now prescan, then convert, all the arguments. */
4105 = ffeste_io_inlist_ (errl
|| iostat
,
4106 &info
->inquire_spec
[FFESTP_inquireixUNIT
],
4107 &info
->inquire_spec
[FFESTP_inquireixFILE
],
4108 &info
->inquire_spec
[FFESTP_inquireixEXIST
],
4109 &info
->inquire_spec
[FFESTP_inquireixOPENED
],
4110 &info
->inquire_spec
[FFESTP_inquireixNUMBER
],
4111 &info
->inquire_spec
[FFESTP_inquireixNAMED
],
4112 &info
->inquire_spec
[FFESTP_inquireixNAME
],
4113 &info
->inquire_spec
[FFESTP_inquireixACCESS
],
4114 &info
->inquire_spec
[FFESTP_inquireixSEQUENTIAL
],
4115 &info
->inquire_spec
[FFESTP_inquireixDIRECT
],
4116 &info
->inquire_spec
[FFESTP_inquireixFORM
],
4117 &info
->inquire_spec
[FFESTP_inquireixFORMATTED
],
4118 &info
->inquire_spec
[FFESTP_inquireixUNFORMATTED
],
4119 &info
->inquire_spec
[FFESTP_inquireixRECL
],
4120 &info
->inquire_spec
[FFESTP_inquireixNEXTREC
],
4121 &info
->inquire_spec
[FFESTP_inquireixBLANK
]);
4123 /* Don't generate "if (iostat != 0) goto label;" if label is temp abort
4124 label, since we're gonna fall through to there anyway. */
4126 ffeste_io_call_ (ffecom_call_gfrt (FFECOM_gfrtFINQU
, args
, NULL_TREE
),
4127 ! ffeste_io_abort_is_temp_
);
4129 /* If we've got a temp label, generate its code here. */
4131 if (ffeste_io_abort_is_temp_
)
4133 DECL_INITIAL (ffeste_io_abort_
) = error_mark_node
;
4135 expand_label (ffeste_io_abort_
);
4137 assert (ffeste_io_err_
== NULL_TREE
);
4140 ffeste_end_stmt_ ();
4143 /* INQUIRE(IOLENGTH=expr) statement -- start. */
4146 ffeste_R923B_start (ffestpInquireStmt
*info UNUSED
)
4148 ffeste_check_start_ ();
4150 assert ("INQUIRE(IOLENGTH=<var>) not implemented yet! ~~~" == NULL
);
4152 ffeste_emit_line_note_ ();
4155 /* INQUIRE(IOLENGTH=expr) statement -- I/O item. */
4158 ffeste_R923B_item (ffebld expr UNUSED
)
4160 ffeste_check_item_ ();
4163 /* INQUIRE(IOLENGTH=expr) statement -- end. */
4166 ffeste_R923B_finish ()
4168 ffeste_check_finish_ ();
4171 /* ffeste_R1001 -- FORMAT statement
4173 ffeste_R1001(format_list); */
4176 ffeste_R1001 (ffests s
)
4183 ffeste_check_simple_ ();
4185 assert (ffeste_label_formatdef_
!= NULL
);
4187 ffeste_emit_line_note_ ();
4189 t
= build_string (ffests_length (s
), ffests_text (s
));
4192 = build_type_variant (build_array_type
4194 build_range_type (integer_type_node
,
4196 build_int_2 (ffests_length (s
),
4199 TREE_CONSTANT (t
) = 1;
4200 TREE_STATIC (t
) = 1;
4202 var
= ffecom_lookup_label (ffeste_label_formatdef_
);
4203 if ((var
!= NULL_TREE
)
4204 && (TREE_CODE (var
) == VAR_DECL
))
4206 DECL_INITIAL (var
) = t
;
4207 maxindex
= build_int_2 (ffests_length (s
) - 1, 0);
4208 ttype
= TREE_TYPE (var
);
4209 TYPE_DOMAIN (ttype
) = build_range_type (integer_type_node
,
4212 if (!TREE_TYPE (maxindex
))
4213 TREE_TYPE (maxindex
) = TYPE_DOMAIN (ttype
);
4214 layout_type (ttype
);
4215 rest_of_decl_compilation (var
, NULL
, 1, 0);
4217 expand_decl_init (var
);
4220 ffeste_label_formatdef_
= NULL
;
4230 /* END BLOCK DATA. */
4237 /* CALL statement. */
4240 ffeste_R1212 (ffebld expr
)
4244 ffebld labels
= NULL
; /* First in list of LABTERs. */
4245 ffebld prevlabels
= NULL
;
4246 ffebld prevargs
= NULL
;
4248 ffeste_check_simple_ ();
4250 args
= ffebld_right (expr
);
4252 ffeste_emit_line_note_ ();
4254 /* Here we split the list at ffebld_right(expr) into two lists: one at
4255 ffebld_right(expr) consisting of all items that are not LABTERs, the
4256 other at labels consisting of all items that are LABTERs. Then, if
4257 the latter list is NULL, we have an ordinary call, else we have a call
4258 with alternate returns. */
4260 for (args
= ffebld_right (expr
); args
!= NULL
; args
= ffebld_trail (args
))
4262 if (((arg
= ffebld_head (args
)) == NULL
)
4263 || (ffebld_op (arg
) != FFEBLD_opLABTER
))
4265 if (prevargs
== NULL
)
4268 ffebld_set_right (expr
, args
);
4272 ffebld_set_trail (prevargs
, args
);
4278 if (prevlabels
== NULL
)
4280 prevlabels
= labels
= args
;
4284 ffebld_set_trail (prevlabels
, args
);
4289 if (prevlabels
== NULL
)
4292 ffebld_set_trail (prevlabels
, NULL
);
4293 if (prevargs
== NULL
)
4294 ffebld_set_right (expr
, NULL
);
4296 ffebld_set_trail (prevargs
, NULL
);
4298 ffeste_start_stmt_ ();
4300 /* No temporaries are actually needed at this level, but we go
4301 through the motions anyway, just to be sure in case they do
4302 get made. Temporaries needed for arguments should be in the
4303 scopes of inner blocks, and if clean-up actions are supported,
4304 such as CALL-ing an intrinsic that writes to an argument of one
4305 type when a variable of a different type is provided (requiring
4306 assignment to the variable from a temporary after the library
4307 routine returns), the clean-up must be done by the expression
4308 evaluator, generally, to handle alternate returns (which we hope
4309 won't ever be supported by intrinsics, but might be a similar
4310 issue, such as CALL-ing an F90-style subroutine with an INTERFACE
4311 block). That implies the expression evaluator will have to
4312 recognize the need for its own temporary anyway, meaning it'll
4313 construct a block within the one constructed here. */
4315 ffecom_prepare_expr (expr
);
4317 ffecom_prepare_end ();
4320 expand_expr_stmt (ffecom_expr (expr
));
4331 texpr
= ffecom_expr (expr
);
4332 expand_start_case (0, texpr
, TREE_TYPE (texpr
), "CALL statement");
4334 for (caseno
= 1, label
= labels
;
4336 ++caseno
, label
= ffebld_trail (label
))
4338 value
= build_int_2 (caseno
, 0);
4339 tlabel
= build_decl (LABEL_DECL
, NULL_TREE
, NULL_TREE
);
4341 pushok
= pushcase (value
, convert
, tlabel
, &duplicate
);
4342 assert (pushok
== 0);
4345 = ffecom_lookup_label (ffebld_labter (ffebld_head (label
)));
4346 if ((tlabel
== NULL_TREE
)
4347 || (TREE_CODE (tlabel
) == ERROR_MARK
))
4349 TREE_USED (tlabel
) = 1;
4350 expand_goto (tlabel
);
4353 expand_end_case (texpr
);
4356 ffeste_end_stmt_ ();
4366 /* END SUBROUTINE. */
4373 /* ENTRY statement. */
4376 ffeste_R1226 (ffesymbol entry
)
4380 ffeste_check_simple_ ();
4382 label
= ffesymbol_hook (entry
).length_tree
;
4384 ffeste_emit_line_note_ ();
4386 if (label
== error_mark_node
)
4389 DECL_INITIAL (label
) = error_mark_node
;
4391 expand_label (label
);
4394 /* RETURN statement. */
4397 ffeste_R1227 (ffestw block UNUSED
, ffebld expr
)
4401 ffeste_check_simple_ ();
4403 ffeste_emit_line_note_ ();
4405 ffeste_start_stmt_ ();
4407 ffecom_prepare_return_expr (expr
);
4409 ffecom_prepare_end ();
4411 rtn
= ffecom_return_expr (expr
);
4413 if ((rtn
== NULL_TREE
)
4414 || (rtn
== error_mark_node
))
4415 expand_null_return ();
4418 tree result
= DECL_RESULT (current_function_decl
);
4420 if ((result
!= error_mark_node
)
4421 && (TREE_TYPE (result
) != error_mark_node
))
4422 expand_return (ffecom_modify (NULL_TREE
,
4424 convert (TREE_TYPE (result
),
4427 expand_null_return ();
4430 ffeste_end_stmt_ ();
4433 /* REWRITE statement -- start. */
4437 ffeste_V018_start (ffestpRewriteStmt
*info
, ffestvFormat format
)
4439 ffeste_check_start_ ();
4442 /* REWRITE statement -- I/O item. */
4445 ffeste_V018_item (ffebld expr
)
4447 ffeste_check_item_ ();
4450 /* REWRITE statement -- end. */
4453 ffeste_V018_finish ()
4455 ffeste_check_finish_ ();
4458 /* ACCEPT statement -- start. */
4461 ffeste_V019_start (ffestpAcceptStmt
*info
, ffestvFormat format
)
4463 ffeste_check_start_ ();
4466 /* ACCEPT statement -- I/O item. */
4469 ffeste_V019_item (ffebld expr
)
4471 ffeste_check_item_ ();
4474 /* ACCEPT statement -- end. */
4477 ffeste_V019_finish ()
4479 ffeste_check_finish_ ();
4483 /* TYPE statement -- start. */
4486 ffeste_V020_start (ffestpTypeStmt
*info UNUSED
,
4487 ffestvFormat format UNUSED
)
4489 ffeste_check_start_ ();
4492 /* TYPE statement -- I/O item. */
4495 ffeste_V020_item (ffebld expr UNUSED
)
4497 ffeste_check_item_ ();
4500 /* TYPE statement -- end. */
4503 ffeste_V020_finish ()
4505 ffeste_check_finish_ ();
4508 /* DELETE statement. */
4512 ffeste_V021 (ffestpDeleteStmt
*info
)
4514 ffeste_check_simple_ ();
4517 /* UNLOCK statement. */
4520 ffeste_V022 (ffestpBeruStmt
*info
)
4522 ffeste_check_simple_ ();
4525 /* ENCODE statement -- start. */
4528 ffeste_V023_start (ffestpVxtcodeStmt
*info
)
4530 ffeste_check_start_ ();
4533 /* ENCODE statement -- I/O item. */
4536 ffeste_V023_item (ffebld expr
)
4538 ffeste_check_item_ ();
4541 /* ENCODE statement -- end. */
4544 ffeste_V023_finish ()
4546 ffeste_check_finish_ ();
4549 /* DECODE statement -- start. */
4552 ffeste_V024_start (ffestpVxtcodeStmt
*info
)
4554 ffeste_check_start_ ();
4557 /* DECODE statement -- I/O item. */
4560 ffeste_V024_item (ffebld expr
)
4562 ffeste_check_item_ ();
4565 /* DECODE statement -- end. */
4568 ffeste_V024_finish ()
4570 ffeste_check_finish_ ();
4573 /* DEFINEFILE statement -- start. */
4576 ffeste_V025_start ()
4578 ffeste_check_start_ ();
4581 /* DEFINE FILE statement -- item. */
4584 ffeste_V025_item (ffebld u
, ffebld m
, ffebld n
, ffebld asv
)
4586 ffeste_check_item_ ();
4589 /* DEFINE FILE statement -- end. */
4592 ffeste_V025_finish ()
4594 ffeste_check_finish_ ();
4597 /* FIND statement. */
4600 ffeste_V026 (ffestpFindStmt
*info
)
4602 ffeste_check_simple_ ();
4607 #ifdef ENABLE_CHECKING
4609 ffeste_terminate_2 (void)
4611 assert (! ffeste_top_block_
);
4615 #include "gt-f-ste.h"