1 /* ste.c -- Implementation File (module.c template V1.0)
2 Copyright (C) 1995, 1996, 2000 Free Software Foundation, Inc.
3 Contributed by James Craig Burley.
5 This file is part of GNU Fortran.
7 GNU Fortran is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 2, or (at your option)
12 GNU Fortran is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
17 You should have received a copy of the GNU General Public License
18 along with GNU Fortran; see the file COPYING. If not, write to
19 the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
26 Implements the various statements and such like.
35 #if FFECOM_targetCURRENT == FFECOM_targetGCC
56 /* Externals defined here. */
59 /* Simple definitions and enumerations. */
63 FFESTE_stateletSIMPLE_
, /* Expecting simple/start. */
64 FFESTE_stateletATTRIB_
, /* Expecting attrib/item/itemstart. */
65 FFESTE_stateletITEM_
, /* Expecting item/itemstart/finish. */
66 FFESTE_stateletITEMVALS_
, /* Expecting itemvalue/itemendvals. */
70 /* Internal typedefs. */
73 /* Private include files. */
76 /* Internal structure definitions. */
79 /* Static objects accessed by functions in this module. */
81 static ffesteStatelet_ ffeste_statelet_
= FFESTE_stateletSIMPLE_
;
82 #if FFECOM_targetCURRENT == FFECOM_targetGCC
83 static ffelab ffeste_label_formatdef_
= NULL
;
84 static tree (*ffeste_io_driver_
) (ffebld expr
); /* do?io. */
85 static ffecomGfrt ffeste_io_endgfrt_
; /* end function to call. */
86 static tree ffeste_io_abort_
; /* abort-io label or NULL_TREE. */
87 static bool ffeste_io_abort_is_temp_
; /* abort-io label is a temp. */
88 static tree ffeste_io_end_
; /* END= label or NULL_TREE. */
89 static tree ffeste_io_err_
; /* ERR= label or NULL_TREE. */
90 static tree ffeste_io_iostat_
; /* IOSTAT= var or NULL_TREE. */
91 static bool ffeste_io_iostat_is_temp_
; /* IOSTAT= var is a temp. */
94 /* Static functions (internal). */
96 #if FFECOM_targetCURRENT == FFECOM_targetGCC
97 static void ffeste_begin_iterdo_ (ffestw block
, tree
*tvar
, tree
*tincr
,
98 tree
*xitersvar
, ffebld var
,
99 ffebld start
, ffelexToken start_token
,
100 ffebld end
, ffelexToken end_token
,
101 ffebld incr
, ffelexToken incr_token
,
103 static void ffeste_end_iterdo_ (ffestw block
, tree tvar
, tree tincr
,
105 static void ffeste_io_call_ (tree call
, bool do_check
);
106 static void ffeste_io_impdo_ (ffebld impdo
, ffelexToken impdo_token
);
107 static tree
ffeste_io_dofio_ (ffebld expr
);
108 static tree
ffeste_io_dolio_ (ffebld expr
);
109 static tree
ffeste_io_douio_ (ffebld expr
);
110 static tree
ffeste_io_ialist_ (bool have_err
, ffestvUnit unit
,
111 ffebld unit_expr
, int unit_dflt
);
112 static tree
ffeste_io_cilist_ (bool have_err
, ffestvUnit unit
,
113 ffebld unit_expr
, int unit_dflt
,
114 bool have_end
, ffestvFormat format
,
115 ffestpFile
*format_spec
, bool rec
,
117 static tree
ffeste_io_cllist_ (bool have_err
, ffebld unit_expr
,
118 ffestpFile
*stat_spec
);
119 static tree
ffeste_io_icilist_ (bool have_err
, ffebld unit_expr
,
120 bool have_end
, ffestvFormat format
,
121 ffestpFile
*format_spec
);
122 static tree
ffeste_io_inlist_ (bool have_err
,
123 ffestpFile
*unit_spec
,
124 ffestpFile
*file_spec
,
125 ffestpFile
*exist_spec
,
126 ffestpFile
*open_spec
,
127 ffestpFile
*number_spec
,
128 ffestpFile
*named_spec
,
129 ffestpFile
*name_spec
,
130 ffestpFile
*access_spec
,
131 ffestpFile
*sequential_spec
,
132 ffestpFile
*direct_spec
,
133 ffestpFile
*form_spec
,
134 ffestpFile
*formatted_spec
,
135 ffestpFile
*unformatted_spec
,
136 ffestpFile
*recl_spec
,
137 ffestpFile
*nextrec_spec
,
138 ffestpFile
*blank_spec
);
139 static tree
ffeste_io_olist_ (bool have_err
, ffebld unit_expr
,
140 ffestpFile
*file_spec
,
141 ffestpFile
*stat_spec
,
142 ffestpFile
*access_spec
,
143 ffestpFile
*form_spec
,
144 ffestpFile
*recl_spec
,
145 ffestpFile
*blank_spec
);
146 static void ffeste_subr_beru_ (ffestpBeruStmt
*info
, ffecomGfrt rt
);
147 #elif FFECOM_targetCURRENT == FFECOM_targetFFE
148 static void ffeste_subr_file_ (const char *kw
, ffestpFile
*spec
);
153 /* Internal macros. */
155 #if FFECOM_targetCURRENT == FFECOM_targetGCC
156 #define ffeste_emit_line_note_() \
157 emit_line_note (input_filename, lineno)
159 #define ffeste_check_simple_() \
160 assert(ffeste_statelet_ == FFESTE_stateletSIMPLE_)
161 #define ffeste_check_start_() \
162 assert(ffeste_statelet_ == FFESTE_stateletSIMPLE_); \
163 ffeste_statelet_ = FFESTE_stateletATTRIB_
164 #define ffeste_check_attrib_() \
165 assert(ffeste_statelet_ == FFESTE_stateletATTRIB_)
166 #define ffeste_check_item_() \
167 assert(ffeste_statelet_ == FFESTE_stateletATTRIB_ \
168 || ffeste_statelet_ == FFESTE_stateletITEM_); \
169 ffeste_statelet_ = FFESTE_stateletITEM_
170 #define ffeste_check_item_startvals_() \
171 assert(ffeste_statelet_ == FFESTE_stateletATTRIB_ \
172 || ffeste_statelet_ == FFESTE_stateletITEM_); \
173 ffeste_statelet_ = FFESTE_stateletITEMVALS_
174 #define ffeste_check_item_value_() \
175 assert(ffeste_statelet_ == FFESTE_stateletITEMVALS_)
176 #define ffeste_check_item_endvals_() \
177 assert(ffeste_statelet_ == FFESTE_stateletITEMVALS_); \
178 ffeste_statelet_ = FFESTE_stateletITEM_
179 #define ffeste_check_finish_() \
180 assert(ffeste_statelet_ == FFESTE_stateletATTRIB_ \
181 || ffeste_statelet_ == FFESTE_stateletITEM_); \
182 ffeste_statelet_ = FFESTE_stateletSIMPLE_
184 #define ffeste_f2c_init_charnolen_(Exp,Init,Spec) \
187 if ((Spec)->kw_or_val_present) \
188 Exp = ffecom_arg_ptr_to_const_expr ((Spec)->u.expr, &ignore); \
190 Exp = null_pointer_node; \
195 Init = null_pointer_node; \
200 #define ffeste_f2c_init_char_(Exp,Init,Lenexp,Leninit,Spec) \
203 if ((Spec)->kw_or_val_present) \
204 Exp = ffecom_arg_ptr_to_const_expr ((Spec)->u.expr, &Lenexp); \
207 Exp = null_pointer_node; \
208 Lenexp = ffecom_f2c_ftnlen_zero_node; \
214 Init = null_pointer_node; \
221 Leninit = ffecom_f2c_ftnlen_zero_node; \
226 #define ffeste_f2c_init_flag_(Flag,Init) \
229 Init = convert (ffecom_f2c_flag_type_node, \
230 (Flag) ? integer_one_node : integer_zero_node); \
233 #define ffeste_f2c_init_format_(Exp,Init,Spec) \
236 Exp = ffecom_arg_ptr_to_const_expr ((Spec)->u.expr, NULL); \
241 Init = null_pointer_node; \
246 #define ffeste_f2c_init_int_(Exp,Init,Spec) \
249 if ((Spec)->kw_or_val_present) \
250 Exp = ffecom_const_expr ((Spec)->u.expr); \
252 Exp = ffecom_integer_zero_node; \
257 Init = ffecom_integer_zero_node; \
262 #define ffeste_f2c_init_ptrtoint_(Exp,Init,Spec) \
265 if ((Spec)->kw_or_val_present) \
266 Exp = ffecom_ptr_to_const_expr ((Spec)->u.expr); \
268 Exp = null_pointer_node; \
273 Init = null_pointer_node; \
278 #define ffeste_f2c_init_next_(Init) \
281 TREE_CHAIN (initn) = build_tree_list ((field = TREE_CHAIN (field)), \
283 initn = TREE_CHAIN(initn); \
286 #define ffeste_f2c_prepare_charnolen_(Spec,Exp) \
290 ffecom_prepare_arg_ptr_to_expr ((Spec)->u.expr); \
293 #define ffeste_f2c_prepare_char_(Spec,Exp) \
297 ffecom_prepare_arg_ptr_to_expr ((Spec)->u.expr); \
300 #define ffeste_f2c_prepare_format_(Spec,Exp) \
304 ffecom_prepare_arg_ptr_to_expr ((Spec)->u.expr); \
307 #define ffeste_f2c_prepare_int_(Spec,Exp) \
311 ffecom_prepare_expr ((Spec)->u.expr); \
314 #define ffeste_f2c_prepare_ptrtoint_(Spec,Exp) \
318 ffecom_prepare_ptr_to_expr ((Spec)->u.expr); \
321 #define ffeste_f2c_compile_(Field,Exp) \
327 exz = ffecom_modify (void_type_node, \
328 ffecom_2 (COMPONENT_REF, TREE_TYPE (Field), \
331 expand_expr_stmt (exz); \
335 #define ffeste_f2c_compile_charnolen_(Field,Spec,Exp) \
341 exq = ffecom_arg_ptr_to_expr ((Spec)->u.expr, &ignore); \
342 ffeste_f2c_compile_ ((Field), exq); \
346 #define ffeste_f2c_compile_char_(Field,Lenfield,Spec,Exp,Lenexp) \
350 tree lenexq = (Lenexp); \
351 int need_exq = (! exq); \
352 int need_lenexq = (! lenexq); \
353 if (need_exq || need_lenexq) \
355 exq = ffecom_arg_ptr_to_expr ((Spec)->u.expr, &lenexq); \
357 ffeste_f2c_compile_ ((Field), exq); \
359 ffeste_f2c_compile_ ((Lenfield), lenexq); \
363 #define ffeste_f2c_compile_format_(Field,Spec,Exp) \
369 exq = ffecom_arg_ptr_to_expr ((Spec)->u.expr, NULL); \
370 ffeste_f2c_compile_ ((Field), exq); \
374 #define ffeste_f2c_compile_int_(Field,Spec,Exp) \
380 exq = ffecom_expr ((Spec)->u.expr); \
381 ffeste_f2c_compile_ ((Field), exq); \
385 #define ffeste_f2c_compile_ptrtoint_(Field,Spec,Exp) \
391 exq = ffecom_ptr_to_expr ((Spec)->u.expr); \
392 ffeste_f2c_compile_ ((Field), exq); \
396 /* Start a Fortran block. */
398 #ifdef ENABLE_CHECKING
400 typedef struct gbe_block
402 struct gbe_block
*outer
;
405 const char *input_filename
;
409 gbe_block ffeste_top_block_
= NULL
;
412 ffeste_start_block_ (ffestw block
)
414 gbe_block b
= xmalloc (sizeof (*b
));
416 b
->outer
= ffeste_top_block_
;
419 b
->input_filename
= input_filename
;
422 ffeste_top_block_
= b
;
424 ffecom_start_compstmt ();
427 /* End a Fortran block. */
430 ffeste_end_block_ (ffestw block
)
432 gbe_block b
= ffeste_top_block_
;
435 assert (! b
->is_stmt
);
436 assert (b
->block
== block
);
437 assert (! b
->is_stmt
);
439 ffeste_top_block_
= b
->outer
;
445 ffecom_end_compstmt ();
448 /* Start a Fortran statement.
450 Starts a back-end block, so temporaries can be managed, clean-ups
451 properly handled, etc. Nesting of statements *is* allowed -- the
452 handling of I/O items, even implied-DO I/O lists, within a READ,
453 PRINT, or WRITE statement is one example. */
456 ffeste_start_stmt_(void)
458 gbe_block b
= xmalloc (sizeof (*b
));
460 b
->outer
= ffeste_top_block_
;
463 b
->input_filename
= input_filename
;
466 ffeste_top_block_
= b
;
468 ffecom_start_compstmt ();
471 /* End a Fortran statement. */
474 ffeste_end_stmt_(void)
476 gbe_block b
= ffeste_top_block_
;
481 ffeste_top_block_
= b
->outer
;
487 ffecom_end_compstmt ();
490 #else /* ! defined (ENABLE_CHECKING) */
492 #define ffeste_start_block_(b) ffecom_start_compstmt ()
493 #define ffeste_end_block_(b) \
496 clear_momentary (); \
497 ffecom_end_compstmt (); \
499 #define ffeste_start_stmt_() ffeste_start_block_(NULL)
500 #define ffeste_end_stmt_() ffeste_end_block_(NULL)
502 #endif /* ! defined (ENABLE_CHECKING) */
504 /* Begin an iterative DO loop. Pass the block to start if applicable.
506 NOTE: Does _two_ push_momentary () calls, which the caller must
507 undo (by calling ffeste_end_iterdo_). */
509 #if FFECOM_targetCURRENT == FFECOM_targetGCC
511 ffeste_begin_iterdo_ (ffestw block
, tree
*xtvar
, tree
*xtincr
,
512 tree
*xitersvar
, ffebld var
,
513 ffebld start
, ffelexToken start_token
,
514 ffebld end
, ffelexToken end_token
,
515 ffebld incr
, ffelexToken incr_token
,
525 struct nesting
*expanded_loop
;
527 /* Want to have tvar, tincr, and niters for the whole loop body. */
530 ffeste_start_block_ (block
);
532 ffeste_start_stmt_ ();
534 niters
= ffecom_make_tempvar (block
? "do" : "impdo",
535 ffecom_integer_type_node
,
536 FFETARGET_charactersizeNONE
, -1);
538 ffecom_prepare_expr (incr
);
539 ffecom_prepare_expr_rw (NULL_TREE
, var
);
541 ffecom_prepare_end ();
543 tvar
= ffecom_expr_rw (NULL_TREE
, var
);
544 tincr
= ffecom_expr (incr
);
546 if (TREE_CODE (tvar
) == ERROR_MARK
547 || TREE_CODE (tincr
) == ERROR_MARK
)
551 ffeste_end_block_ (block
);
552 ffestw_set_do_tvar (block
, error_mark_node
);
557 *xtvar
= error_mark_node
;
562 /* Check whether incr is known to be zero, complain and fix. */
564 if (integer_zerop (tincr
) || real_zerop (tincr
))
566 ffebad_start (FFEBAD_DO_STEP_ZERO
);
567 ffebad_here (0, ffelex_token_where_line (incr_token
),
568 ffelex_token_where_column (incr_token
));
571 tincr
= convert (TREE_TYPE (tvar
), integer_one_node
);
574 tincr_saved
= ffecom_save_tree (tincr
);
576 preserve_momentary ();
578 /* Want to have tstart, tend for just this statement. */
580 ffeste_start_stmt_ ();
582 ffecom_prepare_expr (start
);
583 ffecom_prepare_expr (end
);
585 ffecom_prepare_end ();
587 tstart
= ffecom_expr (start
);
588 tend
= ffecom_expr (end
);
590 if (TREE_CODE (tstart
) == ERROR_MARK
591 || TREE_CODE (tend
) == ERROR_MARK
)
597 ffeste_end_block_ (block
);
598 ffestw_set_do_tvar (block
, error_mark_node
);
603 *xtvar
= error_mark_node
;
608 /* For warnings only, nothing else happens here. */
612 if (! ffe_is_onetrip ())
614 try = ffecom_2 (MINUS_EXPR
, TREE_TYPE (tvar
),
618 try = ffecom_2 (PLUS_EXPR
, TREE_TYPE (tvar
),
622 if (TREE_CODE (TREE_TYPE (tvar
)) != REAL_TYPE
)
623 try = ffecom_2 (TRUNC_DIV_EXPR
, integer_type_node
, try,
626 try = convert (integer_type_node
,
627 ffecom_2 (RDIV_EXPR
, TREE_TYPE (tvar
),
631 /* Warn if loop never executed, since we've done the evaluation
632 of the unofficial iteration count already. */
634 try = ffecom_truth_value (ffecom_2 (LE_EXPR
, integer_type_node
,
636 convert (TREE_TYPE (tvar
),
637 integer_zero_node
)));
639 if (integer_onep (try))
641 ffebad_start (FFEBAD_DO_NULL
);
642 ffebad_here (0, ffelex_token_where_line (start_token
),
643 ffelex_token_where_column (start_token
));
649 /* Warn if end plus incr would overflow. */
651 try = ffecom_2 (PLUS_EXPR
, TREE_TYPE (tvar
),
655 if ((TREE_CODE_CLASS (TREE_CODE (try)) == 'c')
656 && TREE_CONSTANT_OVERFLOW (try))
658 ffebad_start (FFEBAD_DO_END_OVERFLOW
);
659 ffebad_here (0, ffelex_token_where_line (end_token
),
660 ffelex_token_where_column (end_token
));
666 /* Do the initial assignment into the DO var. */
668 tstart
= ffecom_save_tree (tstart
);
670 expr
= ffecom_2 (MINUS_EXPR
, TREE_TYPE (tvar
),
674 if (! ffe_is_onetrip ())
676 expr
= ffecom_2 (PLUS_EXPR
, TREE_TYPE (expr
),
678 convert (TREE_TYPE (expr
), tincr_saved
));
681 if (TREE_CODE (TREE_TYPE (tvar
)) != REAL_TYPE
)
682 expr
= ffecom_2 (TRUNC_DIV_EXPR
, TREE_TYPE (expr
),
686 expr
= ffecom_2 (RDIV_EXPR
, TREE_TYPE (expr
),
690 #if 1 /* New, F90-approved approach: convert to default INTEGER. */
691 if (TREE_TYPE (tvar
) != error_mark_node
)
692 expr
= convert (ffecom_integer_type_node
, expr
);
693 #else /* Old approach; convert to INTEGER unless that's a narrowing. */
694 if ((TREE_TYPE (tvar
) != error_mark_node
)
695 && ((TREE_CODE (TREE_TYPE (tvar
)) != INTEGER_TYPE
)
696 || ((TYPE_SIZE (TREE_TYPE (tvar
)) != NULL_TREE
)
697 && ((TREE_CODE (TYPE_SIZE (TREE_TYPE (tvar
)))
699 || (TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (tvar
)))
700 <= TREE_INT_CST_LOW (TYPE_SIZE (ffecom_integer_type_node
)))))))
701 /* Convert unless promoting INTEGER type of any kind downward to
702 default INTEGER; else leave as, say, INTEGER*8 (long long int). */
703 expr
= convert (ffecom_integer_type_node
, expr
);
706 assert (TYPE_MAIN_VARIANT (TREE_TYPE (niters
))
707 == TYPE_MAIN_VARIANT (TREE_TYPE (expr
)));
709 expr
= ffecom_modify (void_type_node
, niters
, expr
);
710 expand_expr_stmt (expr
);
712 expr
= ffecom_modify (void_type_node
, tvar
, tstart
);
713 expand_expr_stmt (expr
);
717 expanded_loop
= expand_start_loop_continue_elsewhere (!! block
);
719 ffestw_set_do_hook (block
, expanded_loop
);
721 if (! ffe_is_onetrip ())
723 expr
= ffecom_truth_value
724 (ffecom_2 (GE_EXPR
, integer_type_node
,
725 ffecom_2 (PREDECREMENT_EXPR
,
728 convert (TREE_TYPE (niters
),
729 ffecom_integer_one_node
)),
730 convert (TREE_TYPE (niters
),
731 ffecom_integer_zero_node
)));
733 expand_exit_loop_if_false (0, expr
);
738 ffestw_set_do_tvar (block
, tvar
);
739 ffestw_set_do_incr_saved (block
, tincr_saved
);
740 ffestw_set_do_count_var (block
, niters
);
745 *xtincr
= tincr_saved
;
752 /* End an iterative DO loop. Pass the same iteration variable and increment
753 value trees that were generated in the paired _begin_ call. */
755 #if FFECOM_targetCURRENT == FFECOM_targetGCC
757 ffeste_end_iterdo_ (ffestw block
, tree tvar
, tree tincr
, tree itersvar
)
760 tree niters
= itersvar
;
762 if (tvar
== error_mark_node
)
765 expand_loop_continue_here ();
767 ffeste_start_stmt_ ();
769 if (ffe_is_onetrip ())
771 expr
= ffecom_truth_value
772 (ffecom_2 (GE_EXPR
, integer_type_node
,
773 ffecom_2 (PREDECREMENT_EXPR
,
776 convert (TREE_TYPE (niters
),
777 ffecom_integer_one_node
)),
778 convert (TREE_TYPE (niters
),
779 ffecom_integer_zero_node
)));
781 expand_exit_loop_if_false (0, expr
);
784 expr
= ffecom_modify (void_type_node
, tvar
,
785 ffecom_2 (PLUS_EXPR
, TREE_TYPE (tvar
),
788 expand_expr_stmt (expr
);
790 /* Lose the stuff we just built. */
795 /* Lose the tvar and incr_saved trees. */
797 ffeste_end_block_ (block
);
803 /* Generate call to run-time I/O routine. */
805 #if FFECOM_targetCURRENT == FFECOM_targetGCC
807 ffeste_io_call_ (tree call
, bool do_check
)
809 /* Generate the call and optional assignment into iostat var. */
811 TREE_SIDE_EFFECTS (call
) = 1;
812 if (ffeste_io_iostat_
!= NULL_TREE
)
813 call
= ffecom_modify (do_check
? NULL_TREE
: void_type_node
,
814 ffeste_io_iostat_
, call
);
815 expand_expr_stmt (call
);
818 || ffeste_io_abort_
== NULL_TREE
819 || TREE_CODE (ffeste_io_abort_
) == ERROR_MARK
)
822 /* Generate optional test. */
824 expand_start_cond (ffecom_truth_value (ffeste_io_iostat_
), 0);
825 expand_goto (ffeste_io_abort_
);
830 /* Handle implied-DO in I/O list.
832 Expands code to start up the DO loop. Then for each item in the
833 DO loop, handles appropriately (possibly including recursively calling
834 itself). Then expands code to end the DO loop. */
836 #if FFECOM_targetCURRENT == FFECOM_targetGCC
838 ffeste_io_impdo_ (ffebld impdo
, ffelexToken impdo_token
)
840 ffebld var
= ffebld_head (ffebld_right (impdo
));
841 ffebld start
= ffebld_head (ffebld_trail (ffebld_right (impdo
)));
842 ffebld end
= ffebld_head (ffebld_trail (ffebld_trail
843 (ffebld_right (impdo
))));
844 ffebld incr
= ffebld_head (ffebld_trail (ffebld_trail
845 (ffebld_trail (ffebld_right (impdo
)))));
854 incr
= ffebld_new_conter (ffebld_constant_new_integerdefault_val (1));
855 ffebld_set_info (incr
, ffeinfo_new
856 (FFEINFO_basictypeINTEGER
,
857 FFEINFO_kindtypeINTEGERDEFAULT
,
860 FFEINFO_whereCONSTANT
,
861 FFETARGET_charactersizeNONE
));
864 /* Start the DO loop. */
866 start
= ffeexpr_convert_expr (start
, impdo_token
, var
, impdo_token
,
868 end
= ffeexpr_convert_expr (end
, impdo_token
, var
, impdo_token
,
870 incr
= ffeexpr_convert_expr (incr
, impdo_token
, var
, impdo_token
,
873 ffeste_begin_iterdo_ (NULL
, &tvar
, &tincr
, &titervar
, var
,
879 /* Handle the list of items. */
881 for (list
= ffebld_left (impdo
); list
!= NULL
; list
= ffebld_trail (list
))
883 item
= ffebld_head (list
);
887 /* Strip parens off items such as in "READ *,(A)". This is really a bug
888 in the user's code, but I've been told lots of code does this. */
889 while (ffebld_op (item
) == FFEBLD_opPAREN
)
890 item
= ffebld_left (item
);
892 if (ffebld_op (item
) == FFEBLD_opANY
)
895 if (ffebld_op (item
) == FFEBLD_opIMPDO
)
896 ffeste_io_impdo_ (item
, impdo_token
);
899 ffeste_start_stmt_ ();
901 ffecom_prepare_arg_ptr_to_expr (item
);
903 ffecom_prepare_end ();
905 ffeste_io_call_ ((*ffeste_io_driver_
) (item
), TRUE
);
911 /* Generate end of implied-do construct. */
913 ffeste_end_iterdo_ (NULL
, tvar
, tincr
, titervar
);
917 /* I/O driver for formatted I/O item (do_fio)
919 Returns a tree for a CALL_EXPR to the do_fio function, which handles
920 a formatted I/O list item, along with the appropriate arguments for
921 the function. It is up to the caller to set the TREE_SIDE_EFFECTS flag
922 for the CALL_EXPR, expand (emit) the expression, emit any assignment
923 of the result to an IOSTAT= variable, and emit any checking of the
924 result for errors. */
926 #if FFECOM_targetCURRENT == FFECOM_targetGCC
928 ffeste_io_dofio_ (ffebld expr
)
938 bt
= ffeinfo_basictype (ffebld_info (expr
));
939 kt
= ffeinfo_kindtype (ffebld_info (expr
));
941 if ((bt
== FFEINFO_basictypeANY
)
942 || (kt
== FFEINFO_kindtypeANY
))
943 return error_mark_node
;
945 if (bt
== FFEINFO_basictypeCOMPLEX
)
948 bt
= FFEINFO_basictypeREAL
;
953 variable
= ffecom_arg_ptr_to_expr (expr
, &size
);
955 if ((variable
== error_mark_node
)
956 || (size
== error_mark_node
))
957 return error_mark_node
;
959 if (size
== NULL_TREE
) /* Already filled in for CHARACTER type. */
960 { /* "(ftnlen) sizeof(type)" */
961 size
= size_binop (CEIL_DIV_EXPR
,
962 TYPE_SIZE_UNIT (ffecom_tree_type
[bt
][kt
]),
963 size_int (TYPE_PRECISION (char_type_node
)
965 #if 0 /* Assume that while it is possible that char * is wider than
966 ftnlen, no object in Fortran space can get big enough for its
967 size to be wider than ftnlen. I really hope nobody wastes
968 time debugging a case where it can! */
969 assert (TYPE_PRECISION (ffecom_f2c_ftnlen_type_node
)
970 >= TYPE_PRECISION (TREE_TYPE (size
)));
972 size
= convert (ffecom_f2c_ftnlen_type_node
, size
);
975 if (ffeinfo_rank (ffebld_info (expr
)) == 0
976 || TREE_CODE (TREE_TYPE (TREE_TYPE (variable
))) != ARRAY_TYPE
)
978 = is_complex
? ffecom_f2c_ftnlen_two_node
: ffecom_f2c_ftnlen_one_node
;
982 = size_binop (CEIL_DIV_EXPR
,
983 TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (variable
))),
984 convert (sizetype
, size
));
985 num_elements
= size_binop (CEIL_DIV_EXPR
, num_elements
,
986 size_int (TYPE_PRECISION (char_type_node
)
988 num_elements
= convert (ffecom_f2c_ftnlen_type_node
,
993 = ffecom_1 (ADDR_EXPR
, ffecom_f2c_ptr_to_ftnlen_type_node
,
996 variable
= convert (string_type_node
, variable
);
998 arglist
= build_tree_list (NULL_TREE
, num_elements
);
999 TREE_CHAIN (arglist
) = build_tree_list (NULL_TREE
, variable
);
1000 TREE_CHAIN (TREE_CHAIN (arglist
)) = build_tree_list (NULL_TREE
, size
);
1002 return ffecom_call_gfrt (FFECOM_gfrtDOFIO
, arglist
, NULL_TREE
);
1006 /* I/O driver for list-directed I/O item (do_lio)
1008 Returns a tree for a CALL_EXPR to the do_lio function, which handles
1009 a list-directed I/O list item, along with the appropriate arguments for
1010 the function. It is up to the caller to set the TREE_SIDE_EFFECTS flag
1011 for the CALL_EXPR, expand (emit) the expression, emit any assignment
1012 of the result to an IOSTAT= variable, and emit any checking of the
1013 result for errors. */
1015 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1017 ffeste_io_dolio_ (ffebld expr
)
1024 ffeinfoBasictype bt
;
1028 bt
= ffeinfo_basictype (ffebld_info (expr
));
1029 kt
= ffeinfo_kindtype (ffebld_info (expr
));
1031 if ((bt
== FFEINFO_basictypeANY
)
1032 || (kt
== FFEINFO_kindtypeANY
))
1033 return error_mark_node
;
1035 tc
= ffecom_f2c_typecode (bt
, kt
);
1037 type_id
= build_int_2 (tc
, 0);
1040 = ffecom_1 (ADDR_EXPR
, ffecom_f2c_ptr_to_ftnint_type_node
,
1041 convert (ffecom_f2c_ftnint_type_node
,
1044 variable
= ffecom_arg_ptr_to_expr (expr
, &size
);
1046 if ((type_id
== error_mark_node
)
1047 || (variable
== error_mark_node
)
1048 || (size
== error_mark_node
))
1049 return error_mark_node
;
1051 if (size
== NULL_TREE
) /* Already filled in for CHARACTER type. */
1052 { /* "(ftnlen) sizeof(type)" */
1053 size
= size_binop (CEIL_DIV_EXPR
,
1054 TYPE_SIZE_UNIT (ffecom_tree_type
[bt
][kt
]),
1055 size_int (TYPE_PRECISION (char_type_node
)
1057 #if 0 /* Assume that while it is possible that char * is wider than
1058 ftnlen, no object in Fortran space can get big enough for its
1059 size to be wider than ftnlen. I really hope nobody wastes
1060 time debugging a case where it can! */
1061 assert (TYPE_PRECISION (ffecom_f2c_ftnlen_type_node
)
1062 >= TYPE_PRECISION (TREE_TYPE (size
)));
1064 size
= convert (ffecom_f2c_ftnlen_type_node
, size
);
1067 if (ffeinfo_rank (ffebld_info (expr
)) == 0
1068 || TREE_CODE (TREE_TYPE (TREE_TYPE (variable
))) != ARRAY_TYPE
)
1069 num_elements
= ffecom_integer_one_node
;
1073 = size_binop (CEIL_DIV_EXPR
,
1074 TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (variable
))),
1075 convert (sizetype
, size
));
1076 num_elements
= size_binop (CEIL_DIV_EXPR
, num_elements
,
1077 size_int (TYPE_PRECISION (char_type_node
)
1079 num_elements
= convert (ffecom_f2c_ftnlen_type_node
,
1084 = ffecom_1 (ADDR_EXPR
, ffecom_f2c_ptr_to_ftnlen_type_node
,
1087 variable
= convert (string_type_node
, variable
);
1089 arglist
= build_tree_list (NULL_TREE
, type_id
);
1090 TREE_CHAIN (arglist
) = build_tree_list (NULL_TREE
, num_elements
);
1091 TREE_CHAIN (TREE_CHAIN (arglist
)) = build_tree_list (NULL_TREE
, variable
);
1092 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (arglist
)))
1093 = build_tree_list (NULL_TREE
, size
);
1095 return ffecom_call_gfrt (FFECOM_gfrtDOLIO
, arglist
, NULL_TREE
);
1099 /* I/O driver for unformatted I/O item (do_uio)
1101 Returns a tree for a CALL_EXPR to the do_uio function, which handles
1102 an unformatted I/O list item, along with the appropriate arguments for
1103 the function. It is up to the caller to set the TREE_SIDE_EFFECTS flag
1104 for the CALL_EXPR, expand (emit) the expression, emit any assignment
1105 of the result to an IOSTAT= variable, and emit any checking of the
1106 result for errors. */
1108 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1110 ffeste_io_douio_ (ffebld expr
)
1116 ffeinfoBasictype bt
;
1120 bt
= ffeinfo_basictype (ffebld_info (expr
));
1121 kt
= ffeinfo_kindtype (ffebld_info (expr
));
1123 if ((bt
== FFEINFO_basictypeANY
)
1124 || (kt
== FFEINFO_kindtypeANY
))
1125 return error_mark_node
;
1127 if (bt
== FFEINFO_basictypeCOMPLEX
)
1130 bt
= FFEINFO_basictypeREAL
;
1135 variable
= ffecom_arg_ptr_to_expr (expr
, &size
);
1137 if ((variable
== error_mark_node
)
1138 || (size
== error_mark_node
))
1139 return error_mark_node
;
1141 if (size
== NULL_TREE
) /* Already filled in for CHARACTER type. */
1142 { /* "(ftnlen) sizeof(type)" */
1143 size
= size_binop (CEIL_DIV_EXPR
,
1144 TYPE_SIZE_UNIT (ffecom_tree_type
[bt
][kt
]),
1145 size_int (TYPE_PRECISION (char_type_node
)
1147 #if 0 /* Assume that while it is possible that char * is wider than
1148 ftnlen, no object in Fortran space can get big enough for its
1149 size to be wider than ftnlen. I really hope nobody wastes
1150 time debugging a case where it can! */
1151 assert (TYPE_PRECISION (ffecom_f2c_ftnlen_type_node
)
1152 >= TYPE_PRECISION (TREE_TYPE (size
)));
1154 size
= convert (ffecom_f2c_ftnlen_type_node
, size
);
1157 if (ffeinfo_rank (ffebld_info (expr
)) == 0
1158 || TREE_CODE (TREE_TYPE (TREE_TYPE (variable
))) != ARRAY_TYPE
)
1160 = is_complex
? ffecom_f2c_ftnlen_two_node
: ffecom_f2c_ftnlen_one_node
;
1164 = size_binop (CEIL_DIV_EXPR
,
1165 TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (variable
))),
1166 convert (sizetype
, size
));
1167 num_elements
= size_binop (CEIL_DIV_EXPR
, num_elements
,
1168 size_int (TYPE_PRECISION (char_type_node
)
1170 num_elements
= convert (ffecom_f2c_ftnlen_type_node
,
1175 = ffecom_1 (ADDR_EXPR
, ffecom_f2c_ptr_to_ftnlen_type_node
,
1178 variable
= convert (string_type_node
, variable
);
1180 arglist
= build_tree_list (NULL_TREE
, num_elements
);
1181 TREE_CHAIN (arglist
) = build_tree_list (NULL_TREE
, variable
);
1182 TREE_CHAIN (TREE_CHAIN (arglist
)) = build_tree_list (NULL_TREE
, size
);
1184 return ffecom_call_gfrt (FFECOM_gfrtDOUIO
, arglist
, NULL_TREE
);
1188 /* Make arglist with ptr to BACKSPACE/ENDFILE/REWIND control list.
1190 Returns a tree suitable as an argument list containing a pointer to
1191 a BACKSPACE/ENDFILE/REWIND control list. First, generates that control
1192 list, if necessary, along with any static and run-time initializations
1193 that are needed as specified by the arguments to this function.
1195 Must ensure that all expressions are prepared before being evaluated,
1196 for any whose evaluation might result in the generation of temporaries.
1198 Note that this means this function causes a transition, within the
1199 current block being code-generated via the back end, from the
1200 declaration of variables (temporaries) to the expanding of expressions,
1203 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1205 ffeste_io_ialist_ (bool have_err
,
1210 static tree f2c_alist_struct
= NULL_TREE
;
1216 bool constantp
= TRUE
;
1217 static tree errfield
, unitfield
;
1218 tree errinit
, unitinit
;
1220 static int mynumber
= 0;
1222 if (f2c_alist_struct
== NULL_TREE
)
1226 ref
= make_node (RECORD_TYPE
);
1228 errfield
= ffecom_decl_field (ref
, NULL_TREE
, "err",
1229 ffecom_f2c_flag_type_node
);
1230 unitfield
= ffecom_decl_field (ref
, errfield
, "unit",
1231 ffecom_f2c_ftnint_type_node
);
1233 TYPE_FIELDS (ref
) = errfield
;
1236 ggc_add_tree_root (&f2c_alist_struct
, 1);
1238 f2c_alist_struct
= ref
;
1241 /* Try to do as much compile-time initialization of the structure
1242 as possible, to save run time. */
1244 ffeste_f2c_init_flag_ (have_err
, errinit
);
1248 case FFESTV_unitNONE
:
1249 case FFESTV_unitASTERISK
:
1250 unitinit
= build_int_2 (unit_dflt
, 0);
1254 case FFESTV_unitINTEXPR
:
1255 unitexp
= ffecom_const_expr (unit_expr
);
1260 unitinit
= ffecom_integer_zero_node
;
1266 assert ("bad unit spec" == NULL
);
1267 unitinit
= ffecom_integer_zero_node
;
1272 inits
= build_tree_list ((field
= TYPE_FIELDS (f2c_alist_struct
)), errinit
);
1274 ffeste_f2c_init_next_ (unitinit
);
1276 inits
= build (CONSTRUCTOR
, f2c_alist_struct
, NULL_TREE
, inits
);
1277 TREE_CONSTANT (inits
) = constantp
? 1 : 0;
1278 TREE_STATIC (inits
) = 1;
1280 yes
= suspend_momentary ();
1282 t
= build_decl (VAR_DECL
,
1283 ffecom_get_invented_identifier ("__g77_alist_%d",
1286 TREE_STATIC (t
) = 1;
1287 t
= ffecom_start_decl (t
, 1);
1288 ffecom_finish_decl (t
, inits
, 0);
1290 resume_momentary (yes
);
1292 /* Prepare run-time expressions. */
1295 ffecom_prepare_expr (unit_expr
);
1297 ffecom_prepare_end ();
1299 /* Now evaluate run-time expressions as needed. */
1303 unitexp
= ffecom_expr (unit_expr
);
1304 ffeste_f2c_compile_ (unitfield
, unitexp
);
1307 ttype
= build_pointer_type (TREE_TYPE (t
));
1308 t
= ffecom_1 (ADDR_EXPR
, ttype
, t
);
1310 t
= build_tree_list (NULL_TREE
, t
);
1316 /* Make arglist with ptr to external-I/O control list.
1318 Returns a tree suitable as an argument list containing a pointer to
1319 an external-I/O control list. First, generates that control
1320 list, if necessary, along with any static and run-time initializations
1321 that are needed as specified by the arguments to this function.
1323 Must ensure that all expressions are prepared before being evaluated,
1324 for any whose evaluation might result in the generation of temporaries.
1326 Note that this means this function causes a transition, within the
1327 current block being code-generated via the back end, from the
1328 declaration of variables (temporaries) to the expanding of expressions,
1331 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1333 ffeste_io_cilist_ (bool have_err
,
1338 ffestvFormat format
,
1339 ffestpFile
*format_spec
,
1343 static tree f2c_cilist_struct
= NULL_TREE
;
1349 bool constantp
= TRUE
;
1350 static tree errfield
, unitfield
, endfield
, formatfield
, recfield
;
1351 tree errinit
, unitinit
, endinit
, formatinit
, recinit
;
1352 tree unitexp
, formatexp
, recexp
;
1353 static int mynumber
= 0;
1355 if (f2c_cilist_struct
== NULL_TREE
)
1359 ref
= make_node (RECORD_TYPE
);
1361 errfield
= ffecom_decl_field (ref
, NULL_TREE
, "err",
1362 ffecom_f2c_flag_type_node
);
1363 unitfield
= ffecom_decl_field (ref
, errfield
, "unit",
1364 ffecom_f2c_ftnint_type_node
);
1365 endfield
= ffecom_decl_field (ref
, unitfield
, "end",
1366 ffecom_f2c_flag_type_node
);
1367 formatfield
= ffecom_decl_field (ref
, endfield
, "format",
1369 recfield
= ffecom_decl_field (ref
, formatfield
, "rec",
1370 ffecom_f2c_ftnint_type_node
);
1372 TYPE_FIELDS (ref
) = errfield
;
1375 ggc_add_tree_root (&f2c_cilist_struct
, 1);
1377 f2c_cilist_struct
= ref
;
1380 /* Try to do as much compile-time initialization of the structure
1381 as possible, to save run time. */
1383 ffeste_f2c_init_flag_ (have_err
, errinit
);
1387 case FFESTV_unitNONE
:
1388 case FFESTV_unitASTERISK
:
1389 unitinit
= build_int_2 (unit_dflt
, 0);
1393 case FFESTV_unitINTEXPR
:
1394 unitexp
= ffecom_const_expr (unit_expr
);
1399 unitinit
= ffecom_integer_zero_node
;
1405 assert ("bad unit spec" == NULL
);
1406 unitinit
= ffecom_integer_zero_node
;
1413 case FFESTV_formatNONE
:
1414 formatinit
= null_pointer_node
;
1415 formatexp
= formatinit
;
1418 case FFESTV_formatLABEL
:
1419 formatexp
= error_mark_node
;
1420 formatinit
= ffecom_lookup_label (format_spec
->u
.label
);
1421 if ((formatinit
== NULL_TREE
)
1422 || (TREE_CODE (formatinit
) == ERROR_MARK
))
1424 formatinit
= ffecom_1 (ADDR_EXPR
,
1425 build_pointer_type (void_type_node
),
1427 TREE_CONSTANT (formatinit
) = 1;
1430 case FFESTV_formatCHAREXPR
:
1431 formatexp
= ffecom_arg_ptr_to_const_expr (format_spec
->u
.expr
, NULL
);
1433 formatinit
= formatexp
;
1436 formatinit
= null_pointer_node
;
1441 case FFESTV_formatASTERISK
:
1442 formatinit
= null_pointer_node
;
1443 formatexp
= formatinit
;
1446 case FFESTV_formatINTEXPR
:
1447 formatinit
= null_pointer_node
;
1448 formatexp
= ffecom_expr_assign (format_spec
->u
.expr
);
1449 if (GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (formatexp
)))
1450 < GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node
))))
1451 error ("ASSIGNed FORMAT specifier is too small");
1452 formatexp
= convert (string_type_node
, formatexp
);
1455 case FFESTV_formatNAMELIST
:
1456 formatinit
= ffecom_expr (format_spec
->u
.expr
);
1457 formatexp
= formatinit
;
1461 assert ("bad format spec" == NULL
);
1462 formatinit
= integer_zero_node
;
1463 formatexp
= formatinit
;
1467 ffeste_f2c_init_flag_ (have_end
, endinit
);
1470 recexp
= ffecom_const_expr (rec_expr
);
1472 recexp
= ffecom_integer_zero_node
;
1477 recinit
= ffecom_integer_zero_node
;
1481 inits
= build_tree_list ((field
= TYPE_FIELDS (f2c_cilist_struct
)), errinit
);
1483 ffeste_f2c_init_next_ (unitinit
);
1484 ffeste_f2c_init_next_ (endinit
);
1485 ffeste_f2c_init_next_ (formatinit
);
1486 ffeste_f2c_init_next_ (recinit
);
1488 inits
= build (CONSTRUCTOR
, f2c_cilist_struct
, NULL_TREE
, inits
);
1489 TREE_CONSTANT (inits
) = constantp
? 1 : 0;
1490 TREE_STATIC (inits
) = 1;
1492 yes
= suspend_momentary ();
1494 t
= build_decl (VAR_DECL
,
1495 ffecom_get_invented_identifier ("__g77_cilist_%d",
1498 TREE_STATIC (t
) = 1;
1499 t
= ffecom_start_decl (t
, 1);
1500 ffecom_finish_decl (t
, inits
, 0);
1502 resume_momentary (yes
);
1504 /* Prepare run-time expressions. */
1507 ffecom_prepare_expr (unit_expr
);
1510 ffecom_prepare_arg_ptr_to_expr (format_spec
->u
.expr
);
1513 ffecom_prepare_expr (rec_expr
);
1515 ffecom_prepare_end ();
1517 /* Now evaluate run-time expressions as needed. */
1521 unitexp
= ffecom_expr (unit_expr
);
1522 ffeste_f2c_compile_ (unitfield
, unitexp
);
1527 formatexp
= ffecom_arg_ptr_to_expr (format_spec
->u
.expr
, NULL
);
1528 ffeste_f2c_compile_ (formatfield
, formatexp
);
1530 else if (format
== FFESTV_formatINTEXPR
)
1531 ffeste_f2c_compile_ (formatfield
, formatexp
);
1535 recexp
= ffecom_expr (rec_expr
);
1536 ffeste_f2c_compile_ (recfield
, recexp
);
1539 ttype
= build_pointer_type (TREE_TYPE (t
));
1540 t
= ffecom_1 (ADDR_EXPR
, ttype
, t
);
1542 t
= build_tree_list (NULL_TREE
, t
);
1548 /* Make arglist with ptr to CLOSE control list.
1550 Returns a tree suitable as an argument list containing a pointer to
1551 a CLOSE-statement control list. First, generates that control
1552 list, if necessary, along with any static and run-time initializations
1553 that are needed as specified by the arguments to this function.
1555 Must ensure that all expressions are prepared before being evaluated,
1556 for any whose evaluation might result in the generation of temporaries.
1558 Note that this means this function causes a transition, within the
1559 current block being code-generated via the back end, from the
1560 declaration of variables (temporaries) to the expanding of expressions,
1563 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1565 ffeste_io_cllist_ (bool have_err
,
1567 ffestpFile
*stat_spec
)
1569 static tree f2c_close_struct
= NULL_TREE
;
1575 tree ignore
; /* Ignore length info for certain fields. */
1576 bool constantp
= TRUE
;
1577 static tree errfield
, unitfield
, statfield
;
1578 tree errinit
, unitinit
, statinit
;
1579 tree unitexp
, statexp
;
1580 static int mynumber
= 0;
1582 if (f2c_close_struct
== NULL_TREE
)
1586 ref
= make_node (RECORD_TYPE
);
1588 errfield
= ffecom_decl_field (ref
, NULL_TREE
, "err",
1589 ffecom_f2c_flag_type_node
);
1590 unitfield
= ffecom_decl_field (ref
, errfield
, "unit",
1591 ffecom_f2c_ftnint_type_node
);
1592 statfield
= ffecom_decl_field (ref
, unitfield
, "stat",
1595 TYPE_FIELDS (ref
) = errfield
;
1598 ggc_add_tree_root (&f2c_close_struct
, 1);
1600 f2c_close_struct
= ref
;
1603 /* Try to do as much compile-time initialization of the structure
1604 as possible, to save run time. */
1606 ffeste_f2c_init_flag_ (have_err
, errinit
);
1608 unitexp
= ffecom_const_expr (unit_expr
);
1613 unitinit
= ffecom_integer_zero_node
;
1617 ffeste_f2c_init_charnolen_ (statexp
, statinit
, stat_spec
);
1619 inits
= build_tree_list ((field
= TYPE_FIELDS (f2c_close_struct
)), errinit
);
1621 ffeste_f2c_init_next_ (unitinit
);
1622 ffeste_f2c_init_next_ (statinit
);
1624 inits
= build (CONSTRUCTOR
, f2c_close_struct
, NULL_TREE
, inits
);
1625 TREE_CONSTANT (inits
) = constantp
? 1 : 0;
1626 TREE_STATIC (inits
) = 1;
1628 yes
= suspend_momentary ();
1630 t
= build_decl (VAR_DECL
,
1631 ffecom_get_invented_identifier ("__g77_cllist_%d",
1634 TREE_STATIC (t
) = 1;
1635 t
= ffecom_start_decl (t
, 1);
1636 ffecom_finish_decl (t
, inits
, 0);
1638 resume_momentary (yes
);
1640 /* Prepare run-time expressions. */
1643 ffecom_prepare_expr (unit_expr
);
1646 ffecom_prepare_arg_ptr_to_expr (stat_spec
->u
.expr
);
1648 ffecom_prepare_end ();
1650 /* Now evaluate run-time expressions as needed. */
1654 unitexp
= ffecom_expr (unit_expr
);
1655 ffeste_f2c_compile_ (unitfield
, unitexp
);
1658 ffeste_f2c_compile_charnolen_ (statfield
, stat_spec
, statexp
);
1660 ttype
= build_pointer_type (TREE_TYPE (t
));
1661 t
= ffecom_1 (ADDR_EXPR
, ttype
, t
);
1663 t
= build_tree_list (NULL_TREE
, t
);
1669 /* Make arglist with ptr to internal-I/O control list.
1671 Returns a tree suitable as an argument list containing a pointer to
1672 an internal-I/O control list. First, generates that control
1673 list, if necessary, along with any static and run-time initializations
1674 that are needed as specified by the arguments to this function.
1676 Must ensure that all expressions are prepared before being evaluated,
1677 for any whose evaluation might result in the generation of temporaries.
1679 Note that this means this function causes a transition, within the
1680 current block being code-generated via the back end, from the
1681 declaration of variables (temporaries) to the expanding of expressions,
1684 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1686 ffeste_io_icilist_ (bool have_err
,
1689 ffestvFormat format
,
1690 ffestpFile
*format_spec
)
1692 static tree f2c_icilist_struct
= NULL_TREE
;
1698 bool constantp
= TRUE
;
1699 static tree errfield
, unitfield
, endfield
, formatfield
, unitlenfield
,
1701 tree errinit
, unitinit
, endinit
, formatinit
, unitleninit
, unitnuminit
;
1702 tree unitexp
, formatexp
, unitlenexp
, unitnumexp
;
1703 static int mynumber
= 0;
1705 if (f2c_icilist_struct
== NULL_TREE
)
1709 ref
= make_node (RECORD_TYPE
);
1711 errfield
= ffecom_decl_field (ref
, NULL_TREE
, "err",
1712 ffecom_f2c_flag_type_node
);
1713 unitfield
= ffecom_decl_field (ref
, errfield
, "unit",
1715 endfield
= ffecom_decl_field (ref
, unitfield
, "end",
1716 ffecom_f2c_flag_type_node
);
1717 formatfield
= ffecom_decl_field (ref
, endfield
, "format",
1719 unitlenfield
= ffecom_decl_field (ref
, formatfield
, "unitlen",
1720 ffecom_f2c_ftnint_type_node
);
1721 unitnumfield
= ffecom_decl_field (ref
, unitlenfield
, "unitnum",
1722 ffecom_f2c_ftnint_type_node
);
1724 TYPE_FIELDS (ref
) = errfield
;
1727 ggc_add_tree_root (&f2c_icilist_struct
, 1);
1729 f2c_icilist_struct
= ref
;
1732 /* Try to do as much compile-time initialization of the structure
1733 as possible, to save run time. */
1735 ffeste_f2c_init_flag_ (have_err
, errinit
);
1737 unitexp
= ffecom_arg_ptr_to_const_expr (unit_expr
, &unitlenexp
);
1742 unitinit
= null_pointer_node
;
1746 unitleninit
= unitlenexp
;
1749 unitleninit
= ffecom_integer_zero_node
;
1753 /* Now see if we can fully initialize the number of elements, or
1754 if we have to compute that at run time. */
1755 if (ffeinfo_rank (ffebld_info (unit_expr
)) == 0
1757 && TREE_CODE (TREE_TYPE (TREE_TYPE (unitexp
))) != ARRAY_TYPE
))
1759 /* Not an array, so just one element. */
1760 unitnuminit
= ffecom_integer_one_node
;
1761 unitnumexp
= unitnuminit
;
1763 else if (unitexp
&& unitlenexp
)
1765 /* An array, but all the info is constant, so compute now. */
1767 = size_binop (CEIL_DIV_EXPR
,
1768 TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (unitexp
))),
1769 convert (sizetype
, unitlenexp
));
1770 unitnuminit
= size_binop (CEIL_DIV_EXPR
, unitnuminit
,
1771 size_int (TYPE_PRECISION (char_type_node
)
1773 unitnumexp
= unitnuminit
;
1777 /* Put off computing until run time. */
1778 unitnuminit
= ffecom_integer_zero_node
;
1779 unitnumexp
= NULL_TREE
;
1785 case FFESTV_formatNONE
:
1786 formatinit
= null_pointer_node
;
1787 formatexp
= formatinit
;
1790 case FFESTV_formatLABEL
:
1791 formatexp
= error_mark_node
;
1792 formatinit
= ffecom_lookup_label (format_spec
->u
.label
);
1793 if ((formatinit
== NULL_TREE
)
1794 || (TREE_CODE (formatinit
) == ERROR_MARK
))
1796 formatinit
= ffecom_1 (ADDR_EXPR
,
1797 build_pointer_type (void_type_node
),
1799 TREE_CONSTANT (formatinit
) = 1;
1802 case FFESTV_formatCHAREXPR
:
1803 ffeste_f2c_init_format_ (formatexp
, formatinit
, format_spec
);
1806 case FFESTV_formatASTERISK
:
1807 formatinit
= null_pointer_node
;
1808 formatexp
= formatinit
;
1811 case FFESTV_formatINTEXPR
:
1812 formatinit
= null_pointer_node
;
1813 formatexp
= ffecom_expr_assign (format_spec
->u
.expr
);
1814 if (GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (formatexp
)))
1815 < GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node
))))
1816 error ("ASSIGNed FORMAT specifier is too small");
1817 formatexp
= convert (string_type_node
, formatexp
);
1821 assert ("bad format spec" == NULL
);
1822 formatinit
= ffecom_integer_zero_node
;
1823 formatexp
= formatinit
;
1827 ffeste_f2c_init_flag_ (have_end
, endinit
);
1829 inits
= build_tree_list ((field
= TYPE_FIELDS (f2c_icilist_struct
)),
1832 ffeste_f2c_init_next_ (unitinit
);
1833 ffeste_f2c_init_next_ (endinit
);
1834 ffeste_f2c_init_next_ (formatinit
);
1835 ffeste_f2c_init_next_ (unitleninit
);
1836 ffeste_f2c_init_next_ (unitnuminit
);
1838 inits
= build (CONSTRUCTOR
, f2c_icilist_struct
, NULL_TREE
, inits
);
1839 TREE_CONSTANT (inits
) = constantp
? 1 : 0;
1840 TREE_STATIC (inits
) = 1;
1842 yes
= suspend_momentary ();
1844 t
= build_decl (VAR_DECL
,
1845 ffecom_get_invented_identifier ("__g77_icilist_%d",
1847 f2c_icilist_struct
);
1848 TREE_STATIC (t
) = 1;
1849 t
= ffecom_start_decl (t
, 1);
1850 ffecom_finish_decl (t
, inits
, 0);
1852 resume_momentary (yes
);
1854 /* Prepare run-time expressions. */
1857 ffecom_prepare_arg_ptr_to_expr (unit_expr
);
1859 ffeste_f2c_prepare_format_ (format_spec
, formatexp
);
1861 ffecom_prepare_end ();
1863 /* Now evaluate run-time expressions as needed. */
1865 if (! unitexp
|| ! unitlenexp
)
1867 int need_unitexp
= (! unitexp
);
1868 int need_unitlenexp
= (! unitlenexp
);
1870 unitexp
= ffecom_arg_ptr_to_expr (unit_expr
, &unitlenexp
);
1872 ffeste_f2c_compile_ (unitfield
, unitexp
);
1873 if (need_unitlenexp
)
1874 ffeste_f2c_compile_ (unitlenfield
, unitlenexp
);
1878 && unitexp
!= error_mark_node
1879 && unitlenexp
!= error_mark_node
)
1882 = size_binop (CEIL_DIV_EXPR
,
1883 TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (unitexp
))),
1884 convert (sizetype
, unitlenexp
));
1885 unitnumexp
= size_binop (CEIL_DIV_EXPR
, unitnumexp
,
1886 size_int (TYPE_PRECISION (char_type_node
)
1888 ffeste_f2c_compile_ (unitnumfield
, unitnumexp
);
1891 if (format
== FFESTV_formatINTEXPR
)
1892 ffeste_f2c_compile_ (formatfield
, formatexp
);
1894 ffeste_f2c_compile_format_ (formatfield
, format_spec
, formatexp
);
1896 ttype
= build_pointer_type (TREE_TYPE (t
));
1897 t
= ffecom_1 (ADDR_EXPR
, ttype
, t
);
1899 t
= build_tree_list (NULL_TREE
, t
);
1905 /* Make arglist with ptr to INQUIRE control list
1907 Returns a tree suitable as an argument list containing a pointer to
1908 an INQUIRE-statement control list. First, generates that control
1909 list, if necessary, along with any static and run-time initializations
1910 that are needed as specified by the arguments to this function.
1912 Must ensure that all expressions are prepared before being evaluated,
1913 for any whose evaluation might result in the generation of temporaries.
1915 Note that this means this function causes a transition, within the
1916 current block being code-generated via the back end, from the
1917 declaration of variables (temporaries) to the expanding of expressions,
1920 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1922 ffeste_io_inlist_ (bool have_err
,
1923 ffestpFile
*unit_spec
,
1924 ffestpFile
*file_spec
,
1925 ffestpFile
*exist_spec
,
1926 ffestpFile
*open_spec
,
1927 ffestpFile
*number_spec
,
1928 ffestpFile
*named_spec
,
1929 ffestpFile
*name_spec
,
1930 ffestpFile
*access_spec
,
1931 ffestpFile
*sequential_spec
,
1932 ffestpFile
*direct_spec
,
1933 ffestpFile
*form_spec
,
1934 ffestpFile
*formatted_spec
,
1935 ffestpFile
*unformatted_spec
,
1936 ffestpFile
*recl_spec
,
1937 ffestpFile
*nextrec_spec
,
1938 ffestpFile
*blank_spec
)
1940 static tree f2c_inquire_struct
= NULL_TREE
;
1946 bool constantp
= TRUE
;
1947 static tree errfield
, unitfield
, filefield
, filelenfield
, existfield
,
1948 openfield
, numberfield
, namedfield
, namefield
, namelenfield
, accessfield
,
1949 accesslenfield
, sequentialfield
, sequentiallenfield
, directfield
, directlenfield
,
1950 formfield
, formlenfield
, formattedfield
, formattedlenfield
, unformattedfield
,
1951 unformattedlenfield
, reclfield
, nextrecfield
, blankfield
, blanklenfield
;
1952 tree errinit
, unitinit
, fileinit
, fileleninit
, existinit
, openinit
, numberinit
,
1953 namedinit
, nameinit
, nameleninit
, accessinit
, accessleninit
, sequentialinit
,
1954 sequentialleninit
, directinit
, directleninit
, forminit
, formleninit
,
1955 formattedinit
, formattedleninit
, unformattedinit
, unformattedleninit
,
1956 reclinit
, nextrecinit
, blankinit
, blankleninit
;
1958 unitexp
, fileexp
, filelenexp
, existexp
, openexp
, numberexp
, namedexp
,
1959 nameexp
, namelenexp
, accessexp
, accesslenexp
, sequentialexp
, sequentiallenexp
,
1960 directexp
, directlenexp
, formexp
, formlenexp
, formattedexp
, formattedlenexp
,
1961 unformattedexp
, unformattedlenexp
, reclexp
, nextrecexp
, blankexp
, blanklenexp
;
1962 static int mynumber
= 0;
1964 if (f2c_inquire_struct
== NULL_TREE
)
1968 ref
= make_node (RECORD_TYPE
);
1970 errfield
= ffecom_decl_field (ref
, NULL_TREE
, "err",
1971 ffecom_f2c_flag_type_node
);
1972 unitfield
= ffecom_decl_field (ref
, errfield
, "unit",
1973 ffecom_f2c_ftnint_type_node
);
1974 filefield
= ffecom_decl_field (ref
, unitfield
, "file",
1976 filelenfield
= ffecom_decl_field (ref
, filefield
, "filelen",
1977 ffecom_f2c_ftnlen_type_node
);
1978 existfield
= ffecom_decl_field (ref
, filelenfield
, "exist",
1979 ffecom_f2c_ptr_to_ftnint_type_node
);
1980 openfield
= ffecom_decl_field (ref
, existfield
, "open",
1981 ffecom_f2c_ptr_to_ftnint_type_node
);
1982 numberfield
= ffecom_decl_field (ref
, openfield
, "number",
1983 ffecom_f2c_ptr_to_ftnint_type_node
);
1984 namedfield
= ffecom_decl_field (ref
, numberfield
, "named",
1985 ffecom_f2c_ptr_to_ftnint_type_node
);
1986 namefield
= ffecom_decl_field (ref
, namedfield
, "name",
1988 namelenfield
= ffecom_decl_field (ref
, namefield
, "namelen",
1989 ffecom_f2c_ftnlen_type_node
);
1990 accessfield
= ffecom_decl_field (ref
, namelenfield
, "access",
1992 accesslenfield
= ffecom_decl_field (ref
, accessfield
, "accesslen",
1993 ffecom_f2c_ftnlen_type_node
);
1994 sequentialfield
= ffecom_decl_field (ref
, accesslenfield
, "sequential",
1996 sequentiallenfield
= ffecom_decl_field (ref
, sequentialfield
,
1998 ffecom_f2c_ftnlen_type_node
);
1999 directfield
= ffecom_decl_field (ref
, sequentiallenfield
, "direct",
2001 directlenfield
= ffecom_decl_field (ref
, directfield
, "directlen",
2002 ffecom_f2c_ftnlen_type_node
);
2003 formfield
= ffecom_decl_field (ref
, directlenfield
, "form",
2005 formlenfield
= ffecom_decl_field (ref
, formfield
, "formlen",
2006 ffecom_f2c_ftnlen_type_node
);
2007 formattedfield
= ffecom_decl_field (ref
, formlenfield
, "formatted",
2009 formattedlenfield
= ffecom_decl_field (ref
, formattedfield
,
2011 ffecom_f2c_ftnlen_type_node
);
2012 unformattedfield
= ffecom_decl_field (ref
, formattedlenfield
,
2015 unformattedlenfield
= ffecom_decl_field (ref
, unformattedfield
,
2017 ffecom_f2c_ftnlen_type_node
);
2018 reclfield
= ffecom_decl_field (ref
, unformattedlenfield
, "recl",
2019 ffecom_f2c_ptr_to_ftnint_type_node
);
2020 nextrecfield
= ffecom_decl_field (ref
, reclfield
, "nextrec",
2021 ffecom_f2c_ptr_to_ftnint_type_node
);
2022 blankfield
= ffecom_decl_field (ref
, nextrecfield
, "blank",
2024 blanklenfield
= ffecom_decl_field (ref
, blankfield
, "blanklen",
2025 ffecom_f2c_ftnlen_type_node
);
2027 TYPE_FIELDS (ref
) = errfield
;
2030 ggc_add_tree_root (&f2c_inquire_struct
, 1);
2032 f2c_inquire_struct
= ref
;
2035 /* Try to do as much compile-time initialization of the structure
2036 as possible, to save run time. */
2038 ffeste_f2c_init_flag_ (have_err
, errinit
);
2039 ffeste_f2c_init_int_ (unitexp
, unitinit
, unit_spec
);
2040 ffeste_f2c_init_char_ (fileexp
, fileinit
, filelenexp
, fileleninit
,
2042 ffeste_f2c_init_ptrtoint_ (existexp
, existinit
, exist_spec
);
2043 ffeste_f2c_init_ptrtoint_ (openexp
, openinit
, open_spec
);
2044 ffeste_f2c_init_ptrtoint_ (numberexp
, numberinit
, number_spec
);
2045 ffeste_f2c_init_ptrtoint_ (namedexp
, namedinit
, named_spec
);
2046 ffeste_f2c_init_char_ (nameexp
, nameinit
, namelenexp
, nameleninit
,
2048 ffeste_f2c_init_char_ (accessexp
, accessinit
, accesslenexp
,
2049 accessleninit
, access_spec
);
2050 ffeste_f2c_init_char_ (sequentialexp
, sequentialinit
, sequentiallenexp
,
2051 sequentialleninit
, sequential_spec
);
2052 ffeste_f2c_init_char_ (directexp
, directinit
, directlenexp
,
2053 directleninit
, direct_spec
);
2054 ffeste_f2c_init_char_ (formexp
, forminit
, formlenexp
, formleninit
,
2056 ffeste_f2c_init_char_ (formattedexp
, formattedinit
,
2057 formattedlenexp
, formattedleninit
, formatted_spec
);
2058 ffeste_f2c_init_char_ (unformattedexp
, unformattedinit
, unformattedlenexp
,
2059 unformattedleninit
, unformatted_spec
);
2060 ffeste_f2c_init_ptrtoint_ (reclexp
, reclinit
, recl_spec
);
2061 ffeste_f2c_init_ptrtoint_ (nextrecexp
, nextrecinit
, nextrec_spec
);
2062 ffeste_f2c_init_char_ (blankexp
, blankinit
, blanklenexp
,
2063 blankleninit
, blank_spec
);
2065 inits
= build_tree_list ((field
= TYPE_FIELDS (f2c_inquire_struct
)),
2068 ffeste_f2c_init_next_ (unitinit
);
2069 ffeste_f2c_init_next_ (fileinit
);
2070 ffeste_f2c_init_next_ (fileleninit
);
2071 ffeste_f2c_init_next_ (existinit
);
2072 ffeste_f2c_init_next_ (openinit
);
2073 ffeste_f2c_init_next_ (numberinit
);
2074 ffeste_f2c_init_next_ (namedinit
);
2075 ffeste_f2c_init_next_ (nameinit
);
2076 ffeste_f2c_init_next_ (nameleninit
);
2077 ffeste_f2c_init_next_ (accessinit
);
2078 ffeste_f2c_init_next_ (accessleninit
);
2079 ffeste_f2c_init_next_ (sequentialinit
);
2080 ffeste_f2c_init_next_ (sequentialleninit
);
2081 ffeste_f2c_init_next_ (directinit
);
2082 ffeste_f2c_init_next_ (directleninit
);
2083 ffeste_f2c_init_next_ (forminit
);
2084 ffeste_f2c_init_next_ (formleninit
);
2085 ffeste_f2c_init_next_ (formattedinit
);
2086 ffeste_f2c_init_next_ (formattedleninit
);
2087 ffeste_f2c_init_next_ (unformattedinit
);
2088 ffeste_f2c_init_next_ (unformattedleninit
);
2089 ffeste_f2c_init_next_ (reclinit
);
2090 ffeste_f2c_init_next_ (nextrecinit
);
2091 ffeste_f2c_init_next_ (blankinit
);
2092 ffeste_f2c_init_next_ (blankleninit
);
2094 inits
= build (CONSTRUCTOR
, f2c_inquire_struct
, NULL_TREE
, inits
);
2095 TREE_CONSTANT (inits
) = constantp
? 1 : 0;
2096 TREE_STATIC (inits
) = 1;
2098 yes
= suspend_momentary ();
2100 t
= build_decl (VAR_DECL
,
2101 ffecom_get_invented_identifier ("__g77_inlist_%d",
2103 f2c_inquire_struct
);
2104 TREE_STATIC (t
) = 1;
2105 t
= ffecom_start_decl (t
, 1);
2106 ffecom_finish_decl (t
, inits
, 0);
2108 resume_momentary (yes
);
2110 /* Prepare run-time expressions. */
2112 ffeste_f2c_prepare_int_ (unit_spec
, unitexp
);
2113 ffeste_f2c_prepare_char_ (file_spec
, fileexp
);
2114 ffeste_f2c_prepare_ptrtoint_ (exist_spec
, existexp
);
2115 ffeste_f2c_prepare_ptrtoint_ (open_spec
, openexp
);
2116 ffeste_f2c_prepare_ptrtoint_ (number_spec
, numberexp
);
2117 ffeste_f2c_prepare_ptrtoint_ (named_spec
, namedexp
);
2118 ffeste_f2c_prepare_char_ (name_spec
, nameexp
);
2119 ffeste_f2c_prepare_char_ (access_spec
, accessexp
);
2120 ffeste_f2c_prepare_char_ (sequential_spec
, sequentialexp
);
2121 ffeste_f2c_prepare_char_ (direct_spec
, directexp
);
2122 ffeste_f2c_prepare_char_ (form_spec
, formexp
);
2123 ffeste_f2c_prepare_char_ (formatted_spec
, formattedexp
);
2124 ffeste_f2c_prepare_char_ (unformatted_spec
, unformattedexp
);
2125 ffeste_f2c_prepare_ptrtoint_ (recl_spec
, reclexp
);
2126 ffeste_f2c_prepare_ptrtoint_ (nextrec_spec
, nextrecexp
);
2127 ffeste_f2c_prepare_char_ (blank_spec
, blankexp
);
2129 ffecom_prepare_end ();
2131 /* Now evaluate run-time expressions as needed. */
2133 ffeste_f2c_compile_int_ (unitfield
, unit_spec
, unitexp
);
2134 ffeste_f2c_compile_char_ (filefield
, filelenfield
, file_spec
,
2135 fileexp
, filelenexp
);
2136 ffeste_f2c_compile_ptrtoint_ (existfield
, exist_spec
, existexp
);
2137 ffeste_f2c_compile_ptrtoint_ (openfield
, open_spec
, openexp
);
2138 ffeste_f2c_compile_ptrtoint_ (numberfield
, number_spec
, numberexp
);
2139 ffeste_f2c_compile_ptrtoint_ (namedfield
, named_spec
, namedexp
);
2140 ffeste_f2c_compile_char_ (namefield
, namelenfield
, name_spec
, nameexp
,
2142 ffeste_f2c_compile_char_ (accessfield
, accesslenfield
, access_spec
,
2143 accessexp
, accesslenexp
);
2144 ffeste_f2c_compile_char_ (sequentialfield
, sequentiallenfield
,
2145 sequential_spec
, sequentialexp
,
2147 ffeste_f2c_compile_char_ (directfield
, directlenfield
, direct_spec
,
2148 directexp
, directlenexp
);
2149 ffeste_f2c_compile_char_ (formfield
, formlenfield
, form_spec
, formexp
,
2151 ffeste_f2c_compile_char_ (formattedfield
, formattedlenfield
, formatted_spec
,
2152 formattedexp
, formattedlenexp
);
2153 ffeste_f2c_compile_char_ (unformattedfield
, unformattedlenfield
,
2154 unformatted_spec
, unformattedexp
,
2156 ffeste_f2c_compile_ptrtoint_ (reclfield
, recl_spec
, reclexp
);
2157 ffeste_f2c_compile_ptrtoint_ (nextrecfield
, nextrec_spec
, nextrecexp
);
2158 ffeste_f2c_compile_char_ (blankfield
, blanklenfield
, blank_spec
, blankexp
,
2161 ttype
= build_pointer_type (TREE_TYPE (t
));
2162 t
= ffecom_1 (ADDR_EXPR
, ttype
, t
);
2164 t
= build_tree_list (NULL_TREE
, t
);
2170 /* Make arglist with ptr to OPEN control list
2172 Returns a tree suitable as an argument list containing a pointer to
2173 an OPEN-statement control list. First, generates that control
2174 list, if necessary, along with any static and run-time initializations
2175 that are needed as specified by the arguments to this function.
2177 Must ensure that all expressions are prepared before being evaluated,
2178 for any whose evaluation might result in the generation of temporaries.
2180 Note that this means this function causes a transition, within the
2181 current block being code-generated via the back end, from the
2182 declaration of variables (temporaries) to the expanding of expressions,
2185 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2187 ffeste_io_olist_ (bool have_err
,
2189 ffestpFile
*file_spec
,
2190 ffestpFile
*stat_spec
,
2191 ffestpFile
*access_spec
,
2192 ffestpFile
*form_spec
,
2193 ffestpFile
*recl_spec
,
2194 ffestpFile
*blank_spec
)
2196 static tree f2c_open_struct
= NULL_TREE
;
2202 tree ignore
; /* Ignore length info for certain fields. */
2203 bool constantp
= TRUE
;
2204 static tree errfield
, unitfield
, filefield
, filelenfield
, statfield
,
2205 accessfield
, formfield
, reclfield
, blankfield
;
2206 tree errinit
, unitinit
, fileinit
, fileleninit
, statinit
, accessinit
,
2207 forminit
, reclinit
, blankinit
;
2209 unitexp
, fileexp
, filelenexp
, statexp
, accessexp
, formexp
, reclexp
,
2211 static int mynumber
= 0;
2213 if (f2c_open_struct
== NULL_TREE
)
2217 ref
= make_node (RECORD_TYPE
);
2219 errfield
= ffecom_decl_field (ref
, NULL_TREE
, "err",
2220 ffecom_f2c_flag_type_node
);
2221 unitfield
= ffecom_decl_field (ref
, errfield
, "unit",
2222 ffecom_f2c_ftnint_type_node
);
2223 filefield
= ffecom_decl_field (ref
, unitfield
, "file",
2225 filelenfield
= ffecom_decl_field (ref
, filefield
, "filelen",
2226 ffecom_f2c_ftnlen_type_node
);
2227 statfield
= ffecom_decl_field (ref
, filelenfield
, "stat",
2229 accessfield
= ffecom_decl_field (ref
, statfield
, "access",
2231 formfield
= ffecom_decl_field (ref
, accessfield
, "form",
2233 reclfield
= ffecom_decl_field (ref
, formfield
, "recl",
2234 ffecom_f2c_ftnint_type_node
);
2235 blankfield
= ffecom_decl_field (ref
, reclfield
, "blank",
2238 TYPE_FIELDS (ref
) = errfield
;
2241 ggc_add_tree_root (&f2c_open_struct
, 1);
2243 f2c_open_struct
= ref
;
2246 /* Try to do as much compile-time initialization of the structure
2247 as possible, to save run time. */
2249 ffeste_f2c_init_flag_ (have_err
, errinit
);
2251 unitexp
= ffecom_const_expr (unit_expr
);
2256 unitinit
= ffecom_integer_zero_node
;
2260 ffeste_f2c_init_char_ (fileexp
, fileinit
, filelenexp
, fileleninit
,
2262 ffeste_f2c_init_charnolen_ (statexp
, statinit
, stat_spec
);
2263 ffeste_f2c_init_charnolen_ (accessexp
, accessinit
, access_spec
);
2264 ffeste_f2c_init_charnolen_ (formexp
, forminit
, form_spec
);
2265 ffeste_f2c_init_int_ (reclexp
, reclinit
, recl_spec
);
2266 ffeste_f2c_init_charnolen_ (blankexp
, blankinit
, blank_spec
);
2268 inits
= build_tree_list ((field
= TYPE_FIELDS (f2c_open_struct
)), errinit
);
2270 ffeste_f2c_init_next_ (unitinit
);
2271 ffeste_f2c_init_next_ (fileinit
);
2272 ffeste_f2c_init_next_ (fileleninit
);
2273 ffeste_f2c_init_next_ (statinit
);
2274 ffeste_f2c_init_next_ (accessinit
);
2275 ffeste_f2c_init_next_ (forminit
);
2276 ffeste_f2c_init_next_ (reclinit
);
2277 ffeste_f2c_init_next_ (blankinit
);
2279 inits
= build (CONSTRUCTOR
, f2c_open_struct
, NULL_TREE
, inits
);
2280 TREE_CONSTANT (inits
) = constantp
? 1 : 0;
2281 TREE_STATIC (inits
) = 1;
2283 yes
= suspend_momentary ();
2285 t
= build_decl (VAR_DECL
,
2286 ffecom_get_invented_identifier ("__g77_olist_%d",
2289 TREE_STATIC (t
) = 1;
2290 t
= ffecom_start_decl (t
, 1);
2291 ffecom_finish_decl (t
, inits
, 0);
2293 resume_momentary (yes
);
2295 /* Prepare run-time expressions. */
2298 ffecom_prepare_expr (unit_expr
);
2300 ffeste_f2c_prepare_char_ (file_spec
, fileexp
);
2301 ffeste_f2c_prepare_charnolen_ (stat_spec
, statexp
);
2302 ffeste_f2c_prepare_charnolen_ (access_spec
, accessexp
);
2303 ffeste_f2c_prepare_charnolen_ (form_spec
, formexp
);
2304 ffeste_f2c_prepare_int_ (recl_spec
, reclexp
);
2305 ffeste_f2c_prepare_charnolen_ (blank_spec
, blankexp
);
2307 ffecom_prepare_end ();
2309 /* Now evaluate run-time expressions as needed. */
2313 unitexp
= ffecom_expr (unit_expr
);
2314 ffeste_f2c_compile_ (unitfield
, unitexp
);
2317 ffeste_f2c_compile_char_ (filefield
, filelenfield
, file_spec
, fileexp
,
2319 ffeste_f2c_compile_charnolen_ (statfield
, stat_spec
, statexp
);
2320 ffeste_f2c_compile_charnolen_ (accessfield
, access_spec
, accessexp
);
2321 ffeste_f2c_compile_charnolen_ (formfield
, form_spec
, formexp
);
2322 ffeste_f2c_compile_int_ (reclfield
, recl_spec
, reclexp
);
2323 ffeste_f2c_compile_charnolen_ (blankfield
, blank_spec
, blankexp
);
2325 ttype
= build_pointer_type (TREE_TYPE (t
));
2326 t
= ffecom_1 (ADDR_EXPR
, ttype
, t
);
2328 t
= build_tree_list (NULL_TREE
, t
);
2334 /* Display file-statement specifier. */
2336 #if FFECOM_targetCURRENT == FFECOM_targetFFE
2338 ffeste_subr_file_ (const char *kw
, ffestpFile
*spec
)
2340 if (!spec
->kw_or_val_present
)
2343 if (spec
->value_present
)
2345 fputc ('=', dmpout
);
2346 if (spec
->value_is_label
)
2348 assert (spec
->value_is_label
== 2); /* Temporary checking only. */
2349 fprintf (dmpout
, "%" ffelabValue_f
"u",
2350 ffelab_value (spec
->u
.label
));
2353 ffebld_dump (spec
->u
.expr
);
2355 fputc (',', dmpout
);
2359 /* Generate code for BACKSPACE/ENDFILE/REWIND. */
2361 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2363 ffeste_subr_beru_ (ffestpBeruStmt
*info
, ffecomGfrt rt
)
2369 ffeste_emit_line_note_ ();
2371 #define specified(something) (info->beru_spec[something].kw_or_val_present)
2373 iostat
= specified (FFESTP_beruixIOSTAT
);
2374 errl
= specified (FFESTP_beruixERR
);
2378 /* ~~For now, we assume the unit number is specified and is not ASTERISK,
2379 because the FFE doesn't support BACKSPACE(*) and rejects a BACKSPACE
2380 without any unit specifier. f2c, however, supports the former
2381 construct. When it is time to add this feature to the FFE, which
2382 probably is fairly easy, ffestc_R919 and company will want to pass an
2383 ffestvUnit indicator of FFESTV_unitINTEXPR or _unitASTERISK to
2384 ffeste_R919 and company, and they will want to pass that same value to
2385 this function, and that argument will replace the constant _unitINTEXPR_
2386 in the call below. Right now, the default unit number, 6, is ignored. */
2388 ffeste_start_stmt_ ();
2392 /* Have ERR= specification. */
2396 = ffecom_lookup_label
2397 (info
->beru_spec
[FFESTP_beruixERR
].u
.label
);
2398 ffeste_io_abort_is_temp_
= FALSE
;
2402 /* No ERR= specification. */
2404 ffeste_io_err_
= NULL_TREE
;
2406 if ((ffeste_io_abort_is_temp_
= iostat
))
2407 ffeste_io_abort_
= ffecom_temp_label ();
2409 ffeste_io_abort_
= NULL_TREE
;
2414 /* Have IOSTAT= specification. */
2416 ffeste_io_iostat_is_temp_
= FALSE
;
2417 ffeste_io_iostat_
= ffecom_expr
2418 (info
->beru_spec
[FFESTP_beruixIOSTAT
].u
.expr
);
2420 else if (ffeste_io_abort_
!= NULL_TREE
)
2422 /* Have no IOSTAT= but have ERR=. */
2424 ffeste_io_iostat_is_temp_
= TRUE
;
2426 = ffecom_make_tempvar ("beru", ffecom_integer_type_node
,
2427 FFETARGET_charactersizeNONE
, -1);
2431 /* No IOSTAT= or ERR= specification. */
2433 ffeste_io_iostat_is_temp_
= FALSE
;
2434 ffeste_io_iostat_
= NULL_TREE
;
2437 /* Now prescan, then convert, all the arguments. */
2439 alist
= ffeste_io_ialist_ (errl
|| iostat
, FFESTV_unitINTEXPR
,
2440 info
->beru_spec
[FFESTP_beruixUNIT
].u
.expr
, 6);
2442 /* Don't generate "if (iostat != 0) goto label;" if label is temp abort
2443 label, since we're gonna fall through to there anyway. */
2445 ffeste_io_call_ (ffecom_call_gfrt (rt
, alist
, NULL_TREE
),
2446 ! ffeste_io_abort_is_temp_
);
2448 /* If we've got a temp label, generate its code here. */
2450 if (ffeste_io_abort_is_temp_
)
2452 DECL_INITIAL (ffeste_io_abort_
) = error_mark_node
;
2454 expand_label (ffeste_io_abort_
);
2456 assert (ffeste_io_err_
== NULL_TREE
);
2459 ffeste_end_stmt_ ();
2465 Also invoked by _labeldef_branch_finish_ (or, in cases
2466 of errors, other _labeldef_ functions) when the label definition is
2467 for a DO-target (LOOPEND) label, once per matching/outstanding DO
2468 block on the stack. */
2471 ffeste_do (ffestw block
)
2473 #if FFECOM_targetCURRENT == FFECOM_targetFFE
2474 fputs ("+ END_DO\n", dmpout
);
2475 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
2476 ffeste_emit_line_note_ ();
2478 if (ffestw_do_tvar (block
) == 0)
2480 expand_end_loop (); /* DO WHILE and just DO. */
2482 ffeste_end_block_ (block
);
2485 ffeste_end_iterdo_ (block
,
2486 ffestw_do_tvar (block
),
2487 ffestw_do_incr_saved (block
),
2488 ffestw_do_count_var (block
));
2494 /* End of statement following logical IF.
2496 Applies to *only* logical IF, not to IF-THEN. */
2501 #if FFECOM_targetCURRENT == FFECOM_targetFFE
2502 fputs ("+ END_IF\n", dmpout
); /* Also see ffeste_R806. */
2503 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
2504 ffeste_emit_line_note_ ();
2508 ffeste_end_block_ (NULL
);
2514 /* Generate "code" for branch label definition. */
2517 ffeste_labeldef_branch (ffelab label
)
2519 #if FFECOM_targetCURRENT == FFECOM_targetFFE
2520 fprintf (dmpout
, "+ label %lu\n", ffelab_value (label
));
2521 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
2525 glabel
= ffecom_lookup_label (label
);
2526 assert (glabel
!= NULL_TREE
);
2527 if (TREE_CODE (glabel
) == ERROR_MARK
)
2530 assert (DECL_INITIAL (glabel
) == NULL_TREE
);
2532 DECL_INITIAL (glabel
) = error_mark_node
;
2533 DECL_SOURCE_FILE (glabel
) = ffelab_definition_filename (label
);
2534 DECL_SOURCE_LINE (glabel
) = ffelab_definition_filelinenum (label
);
2538 expand_label (glabel
);
2545 /* Generate "code" for FORMAT label definition. */
2548 ffeste_labeldef_format (ffelab label
)
2550 #if FFECOM_targetCURRENT == FFECOM_targetFFE
2551 fprintf (dmpout
, "$ label %lu\n", ffelab_value (label
));
2552 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
2553 ffeste_label_formatdef_
= label
;
2559 /* Assignment statement (outside of WHERE). */
2562 ffeste_R737A (ffebld dest
, ffebld source
)
2564 ffeste_check_simple_ ();
2566 #if FFECOM_targetCURRENT == FFECOM_targetFFE
2567 fputs ("+ let ", dmpout
);
2569 fputs ("=", dmpout
);
2570 ffebld_dump (source
);
2571 fputc ('\n', dmpout
);
2572 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
2573 ffeste_emit_line_note_ ();
2575 ffeste_start_stmt_ ();
2577 ffecom_expand_let_stmt (dest
, source
);
2579 ffeste_end_stmt_ ();
2585 /* Block IF (IF-THEN) statement. */
2588 ffeste_R803 (ffestw block
, ffebld expr
)
2590 ffeste_check_simple_ ();
2592 #if FFECOM_targetCURRENT == FFECOM_targetFFE
2593 fputs ("+ IF_block (", dmpout
);
2595 fputs (")\n", dmpout
);
2596 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
2600 ffeste_emit_line_note_ ();
2602 ffeste_start_block_ (block
);
2604 temp
= ffecom_make_tempvar ("ifthen", integer_type_node
,
2605 FFETARGET_charactersizeNONE
, -1);
2607 ffeste_start_stmt_ ();
2609 ffecom_prepare_expr (expr
);
2611 if (ffecom_prepare_end ())
2615 result
= ffecom_modify (void_type_node
,
2617 ffecom_truth_value (ffecom_expr (expr
)));
2619 expand_expr_stmt (result
);
2621 ffeste_end_stmt_ ();
2625 ffeste_end_stmt_ ();
2627 temp
= ffecom_truth_value (ffecom_expr (expr
));
2630 expand_start_cond (temp
, 0);
2632 /* No fake `else' constructs introduced (yet). */
2633 ffestw_set_ifthen_fake_else (block
, 0);
2640 /* ELSE IF statement. */
2643 ffeste_R804 (ffestw block
, ffebld expr
)
2645 ffeste_check_simple_ ();
2647 #if FFECOM_targetCURRENT == FFECOM_targetFFE
2648 fputs ("+ ELSE_IF (", dmpout
);
2650 fputs (")\n", dmpout
);
2651 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
2655 ffeste_emit_line_note_ ();
2657 /* Since ELSEIF(expr) might require preparations for expr,
2658 implement as ELSE; prepare-expr; IF (expr) THEN ...; ENDIF. */
2660 expand_start_else ();
2662 ffeste_start_block_ (block
);
2664 temp
= ffecom_make_tempvar ("elseif", integer_type_node
,
2665 FFETARGET_charactersizeNONE
, -1);
2667 ffeste_start_stmt_ ();
2669 ffecom_prepare_expr (expr
);
2671 if (ffecom_prepare_end ())
2675 result
= ffecom_modify (void_type_node
,
2677 ffecom_truth_value (ffecom_expr (expr
)));
2679 expand_expr_stmt (result
);
2681 ffeste_end_stmt_ ();
2685 /* In this case, we could probably have used expand_start_elseif
2686 instead, saving the need for a fake `else' construct. But,
2687 until it's clear that'd improve performance, it's easier this
2688 way, since we have to expand_start_else before we get to this
2689 test, given the current design. */
2691 ffeste_end_stmt_ ();
2693 temp
= ffecom_truth_value (ffecom_expr (expr
));
2696 expand_start_cond (temp
, 0);
2698 /* Increment number of fake `else' constructs introduced. */
2699 ffestw_set_ifthen_fake_else (block
,
2700 ffestw_ifthen_fake_else (block
) + 1);
2707 /* ELSE statement. */
2710 ffeste_R805 (ffestw block UNUSED
)
2712 ffeste_check_simple_ ();
2714 #if FFECOM_targetCURRENT == FFECOM_targetFFE
2715 fputs ("+ ELSE\n", dmpout
);
2716 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
2717 ffeste_emit_line_note_ ();
2719 expand_start_else ();
2725 /* END IF statement. */
2728 ffeste_R806 (ffestw block
)
2730 #if FFECOM_targetCURRENT == FFECOM_targetFFE
2731 fputs ("+ END_IF_then\n", dmpout
); /* Also see ffeste_shriek_if_. */
2732 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
2734 int i
= ffestw_ifthen_fake_else (block
) + 1;
2736 ffeste_emit_line_note_ ();
2742 ffeste_end_block_ (block
);
2750 /* Logical IF statement. */
2753 ffeste_R807 (ffebld expr
)
2755 ffeste_check_simple_ ();
2757 #if FFECOM_targetCURRENT == FFECOM_targetFFE
2758 fputs ("+ IF_logical (", dmpout
);
2760 fputs (")\n", dmpout
);
2761 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
2765 ffeste_emit_line_note_ ();
2767 ffeste_start_block_ (NULL
);
2769 temp
= ffecom_make_tempvar ("if", integer_type_node
,
2770 FFETARGET_charactersizeNONE
, -1);
2772 ffeste_start_stmt_ ();
2774 ffecom_prepare_expr (expr
);
2776 if (ffecom_prepare_end ())
2780 result
= ffecom_modify (void_type_node
,
2782 ffecom_truth_value (ffecom_expr (expr
)));
2784 expand_expr_stmt (result
);
2786 ffeste_end_stmt_ ();
2790 ffeste_end_stmt_ ();
2792 temp
= ffecom_truth_value (ffecom_expr (expr
));
2795 expand_start_cond (temp
, 0);
2802 /* SELECT CASE statement. */
2805 ffeste_R809 (ffestw block
, ffebld expr
)
2807 ffeste_check_simple_ ();
2809 #if FFECOM_targetCURRENT == FFECOM_targetFFE
2810 fputs ("+ SELECT_CASE (", dmpout
);
2812 fputs (")\n", dmpout
);
2813 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
2814 ffeste_emit_line_note_ ();
2816 ffeste_start_block_ (block
);
2819 || (ffeinfo_basictype (ffebld_info (expr
))
2820 == FFEINFO_basictypeANY
))
2821 ffestw_set_select_texpr (block
, error_mark_node
);
2822 else if (ffeinfo_basictype (ffebld_info (expr
))
2823 == FFEINFO_basictypeCHARACTER
)
2825 /* ~~~Someday handle CHARACTER*1, CHARACTER*N */
2827 ffebad_start_msg ("SELECT CASE on CHARACTER type (at %0) not supported -- sorry",
2828 FFEBAD_severityFATAL
);
2829 ffebad_here (0, ffestw_line (block
), ffestw_col (block
));
2831 ffestw_set_select_texpr (block
, error_mark_node
);
2838 result
= ffecom_make_tempvar ("select", ffecom_type_expr (expr
),
2839 ffeinfo_size (ffebld_info (expr
)),
2842 ffeste_start_stmt_ ();
2844 ffecom_prepare_expr (expr
);
2846 ffecom_prepare_end ();
2848 texpr
= ffecom_expr (expr
);
2850 assert (TYPE_MAIN_VARIANT (TREE_TYPE (texpr
))
2851 == TYPE_MAIN_VARIANT (TREE_TYPE (result
)));
2853 texpr
= ffecom_modify (void_type_node
,
2856 expand_expr_stmt (texpr
);
2858 ffeste_end_stmt_ ();
2860 expand_start_case (1, result
, TREE_TYPE (result
),
2861 "SELECT CASE statement");
2862 ffestw_set_select_texpr (block
, texpr
);
2863 ffestw_set_select_break (block
, FALSE
);
2872 If casenum is 0, it's CASE DEFAULT. Else it's the case ranges at
2873 the start of the first_stmt list in the select object at the top of
2874 the stack that match casenum. */
2877 ffeste_R810 (ffestw block
, unsigned long casenum
)
2879 ffestwSelect s
= ffestw_select (block
);
2882 ffeste_check_simple_ ();
2884 if (s
->first_stmt
== (ffestwCase
) &s
->first_rel
)
2889 #if FFECOM_targetCURRENT == FFECOM_targetFFE
2890 if ((c
== NULL
) || (casenum
!= c
->casenum
))
2892 if (casenum
== 0) /* Intentional CASE DEFAULT. */
2893 fputs ("+ CASE_DEFAULT", dmpout
);
2899 fputs ("+ CASE (", dmpout
);
2903 fputc (',', dmpout
);
2907 ffebld_constant_dump (c
->low
);
2908 if (c
->low
!= c
->high
)
2910 fputc (':', dmpout
);
2911 if (c
->high
!= NULL
)
2912 ffebld_constant_dump (c
->high
);
2916 c
->previous_stmt
->previous_stmt
->next_stmt
= c
;
2917 c
->previous_stmt
= c
->previous_stmt
->previous_stmt
;
2919 while ((c
!= (ffestwCase
) &s
->first_rel
) && (casenum
== c
->casenum
));
2920 fputc (')', dmpout
);
2923 fputc ('\n', dmpout
);
2924 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
2932 ffeste_emit_line_note_ ();
2934 if (ffestw_select_texpr (block
) == error_mark_node
)
2937 /* ~~~Someday handle CHARACTER*1, CHARACTER*N */
2939 tlabel
= build_decl (LABEL_DECL
, NULL_TREE
, NULL_TREE
);
2941 if (ffestw_select_break (block
))
2942 expand_exit_something ();
2944 ffestw_set_select_break (block
, TRUE
);
2946 if ((c
== NULL
) || (casenum
!= c
->casenum
))
2948 if (casenum
== 0) /* Intentional CASE DEFAULT. */
2950 pushok
= pushcase (NULL_TREE
, 0, tlabel
, &duplicate
);
2951 assert (pushok
== 0);
2957 texprlow
= (c
->low
== NULL
) ? NULL_TREE
2958 : ffecom_constantunion (&ffebld_constant_union (c
->low
), s
->type
,
2959 s
->kindtype
, ffecom_tree_type
[s
->type
][s
->kindtype
]);
2960 if (c
->low
!= c
->high
)
2962 texprhigh
= (c
->high
== NULL
) ? NULL_TREE
2963 : ffecom_constantunion (&ffebld_constant_union (c
->high
),
2964 s
->type
, s
->kindtype
, ffecom_tree_type
[s
->type
][s
->kindtype
]);
2965 pushok
= pushcase_range (texprlow
, texprhigh
, convert
,
2966 tlabel
, &duplicate
);
2969 pushok
= pushcase (texprlow
, convert
, tlabel
, &duplicate
);
2970 assert (pushok
== 0);
2973 c
->previous_stmt
->previous_stmt
->next_stmt
= c
;
2974 c
->previous_stmt
= c
->previous_stmt
->previous_stmt
;
2976 while ((c
!= (ffestwCase
) &s
->first_rel
) && (casenum
== c
->casenum
));
2985 /* END SELECT statement. */
2988 ffeste_R811 (ffestw block
)
2990 #if FFECOM_targetCURRENT == FFECOM_targetFFE
2991 fputs ("+ END_SELECT\n", dmpout
);
2992 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
2993 ffeste_emit_line_note_ ();
2995 /* ~~~Someday handle CHARACTER*1, CHARACTER*N */
2997 if (TREE_CODE (ffestw_select_texpr (block
)) != ERROR_MARK
)
2998 expand_end_case (ffestw_select_texpr (block
));
3000 ffeste_end_block_ (block
);
3006 /* Iterative DO statement. */
3009 ffeste_R819A (ffestw block
, ffelab label UNUSED
, ffebld var
,
3010 ffebld start
, ffelexToken start_token
,
3011 ffebld end
, ffelexToken end_token
,
3012 ffebld incr
, ffelexToken incr_token
)
3014 ffeste_check_simple_ ();
3016 #if FFECOM_targetCURRENT == FFECOM_targetFFE
3017 if ((ffebld_op (incr
) == FFEBLD_opCONTER
)
3018 && (ffebld_constant_is_zero (ffebld_conter (incr
))))
3020 ffebad_start (FFEBAD_DO_STEP_ZERO
);
3021 ffebad_here (0, ffelex_token_where_line (incr_token
),
3022 ffelex_token_where_column (incr_token
));
3023 ffebad_string ("Iterative DO loop");
3025 /* Don't bother replacing it with 1 yet. */
3029 fputs ("+ DO_iterative_nonlabeled (", dmpout
);
3031 fprintf (dmpout
, "+ DO_iterative_labeled %lu (", ffelab_value (label
));
3033 fputc ('=', dmpout
);
3034 ffebld_dump (start
);
3035 fputc (',', dmpout
);
3037 fputc (',', dmpout
);
3039 fputs (")\n", dmpout
);
3040 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
3042 ffeste_emit_line_note_ ();
3044 ffeste_begin_iterdo_ (block
, NULL
, NULL
, NULL
,
3049 "Iterative DO loop");
3056 /* DO WHILE statement. */
3059 ffeste_R819B (ffestw block
, ffelab label UNUSED
, ffebld expr
)
3061 ffeste_check_simple_ ();
3063 #if FFECOM_targetCURRENT == FFECOM_targetFFE
3065 fputs ("+ DO_WHILE_nonlabeled (", dmpout
);
3067 fprintf (dmpout
, "+ DO_WHILE_labeled %lu (", ffelab_value (label
));
3069 fputs (")\n", dmpout
);
3070 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
3074 ffeste_emit_line_note_ ();
3076 ffeste_start_block_ (block
);
3080 struct nesting
*loop
;
3083 result
= ffecom_make_tempvar ("dowhile", integer_type_node
,
3084 FFETARGET_charactersizeNONE
, -1);
3085 loop
= expand_start_loop (1);
3087 ffeste_start_stmt_ ();
3089 ffecom_prepare_expr (expr
);
3091 ffecom_prepare_end ();
3093 mod
= ffecom_modify (void_type_node
,
3095 ffecom_truth_value (ffecom_expr (expr
)));
3096 expand_expr_stmt (mod
);
3098 ffeste_end_stmt_ ();
3100 ffestw_set_do_hook (block
, loop
);
3101 expand_exit_loop_if_false (0, result
);
3104 ffestw_set_do_hook (block
, expand_start_loop (1));
3106 ffestw_set_do_tvar (block
, NULL_TREE
);
3113 /* END DO statement.
3115 This is the MIL-STD 1753 END DO. It's syntactic sugar, similar to
3116 CONTINUE (except that it has to have a label that is the target of
3117 one or more iterative DO statement), not the Fortran-90 structured
3118 END DO, which is handled elsewhere, as is the actual mechanism of
3119 ending an iterative DO statement, even one that ends at a label. */
3124 ffeste_check_simple_ ();
3126 #if FFECOM_targetCURRENT == FFECOM_targetFFE
3127 fputs ("+ END_DO_sugar\n", dmpout
);
3128 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
3129 ffeste_emit_line_note_ ();
3137 /* CYCLE statement. */
3140 ffeste_R834 (ffestw block
)
3142 ffeste_check_simple_ ();
3144 #if FFECOM_targetCURRENT == FFECOM_targetFFE
3145 fprintf (dmpout
, "+ CYCLE block #%lu\n", ffestw_blocknum (block
));
3146 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
3147 ffeste_emit_line_note_ ();
3149 expand_continue_loop (ffestw_do_hook (block
));
3155 /* EXIT statement. */
3158 ffeste_R835 (ffestw block
)
3160 ffeste_check_simple_ ();
3162 #if FFECOM_targetCURRENT == FFECOM_targetFFE
3163 fprintf (dmpout
, "+ EXIT block #%lu\n", ffestw_blocknum (block
));
3164 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
3165 ffeste_emit_line_note_ ();
3167 expand_exit_loop (ffestw_do_hook (block
));
3173 /* GOTO statement. */
3176 ffeste_R836 (ffelab label
)
3178 ffeste_check_simple_ ();
3180 #if FFECOM_targetCURRENT == FFECOM_targetFFE
3181 fprintf (dmpout
, "+ GOTO %lu\n", ffelab_value (label
));
3182 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
3186 ffeste_emit_line_note_ ();
3188 glabel
= ffecom_lookup_label (label
);
3189 if ((glabel
!= NULL_TREE
)
3190 && (TREE_CODE (glabel
) != ERROR_MARK
))
3192 expand_goto (glabel
);
3193 TREE_USED (glabel
) = 1;
3201 /* Computed GOTO statement. */
3204 ffeste_R837 (ffelab
*labels
, int count
, ffebld expr
)
3208 ffeste_check_simple_ ();
3210 #if FFECOM_targetCURRENT == FFECOM_targetFFE
3211 fputs ("+ CGOTO (", dmpout
);
3212 for (i
= 0; i
< count
; ++i
)
3215 fputc (',', dmpout
);
3216 fprintf (dmpout
, "%" ffelabValue_f
"u", ffelab_value (labels
[i
]));
3218 fputs ("),", dmpout
);
3220 fputc ('\n', dmpout
);
3221 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
3229 ffeste_emit_line_note_ ();
3231 ffeste_start_stmt_ ();
3233 ffecom_prepare_expr (expr
);
3235 ffecom_prepare_end ();
3237 texpr
= ffecom_expr (expr
);
3239 expand_start_case (0, texpr
, TREE_TYPE (texpr
), "computed GOTO statement");
3241 for (i
= 0; i
< count
; ++i
)
3243 value
= build_int_2 (i
+ 1, 0);
3244 tlabel
= build_decl (LABEL_DECL
, NULL_TREE
, NULL_TREE
);
3246 pushok
= pushcase (value
, convert
, tlabel
, &duplicate
);
3247 assert (pushok
== 0);
3249 tlabel
= ffecom_lookup_label (labels
[i
]);
3250 if ((tlabel
== NULL_TREE
)
3251 || (TREE_CODE (tlabel
) == ERROR_MARK
))
3254 expand_goto (tlabel
);
3255 TREE_USED (tlabel
) = 1;
3257 expand_end_case (texpr
);
3259 ffeste_end_stmt_ ();
3266 /* ASSIGN statement. */
3269 ffeste_R838 (ffelab label
, ffebld target
)
3271 ffeste_check_simple_ ();
3273 #if FFECOM_targetCURRENT == FFECOM_targetFFE
3274 fprintf (dmpout
, "+ ASSIGN %lu TO ", ffelab_value (label
));
3275 ffebld_dump (target
);
3276 fputc ('\n', dmpout
);
3277 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
3283 ffeste_emit_line_note_ ();
3285 /* No need to call ffeste_start_stmt_(), as the sorts of expressions
3286 seen here should never require use of temporaries. */
3288 label_tree
= ffecom_lookup_label (label
);
3289 if ((label_tree
!= NULL_TREE
)
3290 && (TREE_CODE (label_tree
) != ERROR_MARK
))
3292 label_tree
= ffecom_1 (ADDR_EXPR
,
3293 build_pointer_type (void_type_node
),
3295 TREE_CONSTANT (label_tree
) = 1;
3297 target_tree
= ffecom_expr_assign_w (target
);
3298 if (GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (target_tree
)))
3299 < GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (label_tree
))))
3300 error ("ASSIGN to variable that is too small");
3302 label_tree
= convert (TREE_TYPE (target_tree
), label_tree
);
3304 expr_tree
= ffecom_modify (void_type_node
,
3307 expand_expr_stmt (expr_tree
);
3317 /* Assigned GOTO statement. */
3320 ffeste_R839 (ffebld target
)
3322 ffeste_check_simple_ ();
3324 #if FFECOM_targetCURRENT == FFECOM_targetFFE
3325 fputs ("+ AGOTO ", dmpout
);
3326 ffebld_dump (target
);
3327 fputc ('\n', dmpout
);
3328 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
3332 ffeste_emit_line_note_ ();
3334 /* No need to call ffeste_start_stmt_(), as the sorts of expressions
3335 seen here should never require use of temporaries. */
3337 t
= ffecom_expr_assign (target
);
3338 if (GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (t
)))
3339 < GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node
))))
3340 error ("ASSIGNed GOTO target variable is too small");
3342 expand_computed_goto (convert (TREE_TYPE (null_pointer_node
), t
));
3351 /* Arithmetic IF statement. */
3354 ffeste_R840 (ffebld expr
, ffelab neg
, ffelab zero
, ffelab pos
)
3356 ffeste_check_simple_ ();
3358 #if FFECOM_targetCURRENT == FFECOM_targetFFE
3359 fputs ("+ IF_arithmetic (", dmpout
);
3361 fprintf (dmpout
, ") %" ffelabValue_f
"u,%" ffelabValue_f
"u,%" ffelabValue_f
"u\n",
3362 ffelab_value (neg
), ffelab_value (zero
), ffelab_value (pos
));
3363 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
3365 tree gneg
= ffecom_lookup_label (neg
);
3366 tree gzero
= ffecom_lookup_label (zero
);
3367 tree gpos
= ffecom_lookup_label (pos
);
3370 ffeste_emit_line_note_ ();
3372 if ((gneg
== NULL_TREE
) || (gzero
== NULL_TREE
) || (gpos
== NULL_TREE
))
3374 if ((TREE_CODE (gneg
) == ERROR_MARK
)
3375 || (TREE_CODE (gzero
) == ERROR_MARK
)
3376 || (TREE_CODE (gpos
) == ERROR_MARK
))
3379 ffeste_start_stmt_ ();
3381 ffecom_prepare_expr (expr
);
3383 ffecom_prepare_end ();
3388 expand_goto (gzero
);
3391 /* IF (expr.LE.0) THEN GOTO neg/zero ELSE GOTO pos. */
3392 texpr
= ffecom_expr (expr
);
3393 texpr
= ffecom_2 (LE_EXPR
, integer_type_node
,
3395 convert (TREE_TYPE (texpr
),
3396 integer_zero_node
));
3397 expand_start_cond (ffecom_truth_value (texpr
), 0);
3398 expand_goto (gzero
);
3399 expand_start_else ();
3404 else if (neg
== pos
)
3406 /* IF (expr.NE.0) THEN GOTO neg/pos ELSE GOTO zero. */
3407 texpr
= ffecom_expr (expr
);
3408 texpr
= ffecom_2 (NE_EXPR
, integer_type_node
,
3410 convert (TREE_TYPE (texpr
),
3411 integer_zero_node
));
3412 expand_start_cond (ffecom_truth_value (texpr
), 0);
3414 expand_start_else ();
3415 expand_goto (gzero
);
3418 else if (zero
== pos
)
3420 /* IF (expr.GE.0) THEN GOTO zero/pos ELSE GOTO neg. */
3421 texpr
= ffecom_expr (expr
);
3422 texpr
= ffecom_2 (GE_EXPR
, integer_type_node
,
3424 convert (TREE_TYPE (texpr
),
3425 integer_zero_node
));
3426 expand_start_cond (ffecom_truth_value (texpr
), 0);
3427 expand_goto (gzero
);
3428 expand_start_else ();
3434 /* Use a SAVE_EXPR in combo with:
3435 IF (expr.LT.0) THEN GOTO neg
3436 ELSEIF (expr.GT.0) THEN GOTO pos
3438 tree expr_saved
= ffecom_save_tree (ffecom_expr (expr
));
3440 texpr
= ffecom_2 (LT_EXPR
, integer_type_node
,
3442 convert (TREE_TYPE (expr_saved
),
3443 integer_zero_node
));
3444 expand_start_cond (ffecom_truth_value (texpr
), 0);
3446 texpr
= ffecom_2 (GT_EXPR
, integer_type_node
,
3448 convert (TREE_TYPE (expr_saved
),
3449 integer_zero_node
));
3450 expand_start_elseif (ffecom_truth_value (texpr
));
3452 expand_start_else ();
3453 expand_goto (gzero
);
3457 ffeste_end_stmt_ ();
3464 /* CONTINUE statement. */
3469 ffeste_check_simple_ ();
3471 #if FFECOM_targetCURRENT == FFECOM_targetFFE
3472 fputs ("+ CONTINUE\n", dmpout
);
3473 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
3474 ffeste_emit_line_note_ ();
3482 /* STOP statement. */
3485 ffeste_R842 (ffebld expr
)
3487 ffeste_check_simple_ ();
3489 #if FFECOM_targetCURRENT == FFECOM_targetFFE
3492 fputs ("+ STOP\n", dmpout
);
3496 fputs ("+ STOP_coded ", dmpout
);
3498 fputc ('\n', dmpout
);
3500 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
3505 ffeste_emit_line_note_ ();
3508 || (ffeinfo_basictype (ffebld_info (expr
))
3509 == FFEINFO_basictypeANY
))
3511 msg
= ffelex_token_new_character ("", ffelex_token_where_line
3512 (ffesta_tokens
[0]), ffelex_token_where_column
3513 (ffesta_tokens
[0]));
3514 expr
= ffebld_new_conter (ffebld_constant_new_characterdefault
3516 ffelex_token_kill (msg
);
3517 ffebld_set_info (expr
, ffeinfo_new (FFEINFO_basictypeCHARACTER
,
3518 FFEINFO_kindtypeCHARACTERDEFAULT
, 0, FFEINFO_kindENTITY
,
3519 FFEINFO_whereCONSTANT
, 0));
3521 else if (ffeinfo_basictype (ffebld_info (expr
))
3522 == FFEINFO_basictypeINTEGER
)
3526 assert (ffebld_op (expr
) == FFEBLD_opCONTER
);
3527 assert (ffeinfo_kindtype (ffebld_info (expr
))
3528 == FFEINFO_kindtypeINTEGERDEFAULT
);
3529 sprintf (num
, "%" ffetargetIntegerDefault_f
"d",
3530 ffebld_constant_integer1 (ffebld_conter (expr
)));
3531 msg
= ffelex_token_new_character (num
, ffelex_token_where_line
3532 (ffesta_tokens
[0]), ffelex_token_where_column
3533 (ffesta_tokens
[0]));
3534 expr
= ffebld_new_conter (ffebld_constant_new_characterdefault
3536 ffelex_token_kill (msg
);
3537 ffebld_set_info (expr
, ffeinfo_new (FFEINFO_basictypeCHARACTER
,
3538 FFEINFO_kindtypeCHARACTERDEFAULT
, 0, FFEINFO_kindENTITY
,
3539 FFEINFO_whereCONSTANT
, 0));
3543 assert (ffeinfo_basictype (ffebld_info (expr
))
3544 == FFEINFO_basictypeCHARACTER
);
3545 assert (ffebld_op (expr
) == FFEBLD_opCONTER
);
3546 assert (ffeinfo_kindtype (ffebld_info (expr
))
3547 == FFEINFO_kindtypeCHARACTERDEFAULT
);
3550 /* No need to call ffeste_start_stmt_(), as the sorts of expressions
3551 seen here should never require use of temporaries. */
3553 callit
= ffecom_call_gfrt (FFECOM_gfrtSTOP
,
3554 ffecom_list_ptr_to_expr (ffebld_new_item (expr
, NULL
)),
3556 TREE_SIDE_EFFECTS (callit
) = 1;
3558 expand_expr_stmt (callit
);
3567 /* PAUSE statement. */
3570 ffeste_R843 (ffebld expr
)
3572 ffeste_check_simple_ ();
3574 #if FFECOM_targetCURRENT == FFECOM_targetFFE
3577 fputs ("+ PAUSE\n", dmpout
);
3581 fputs ("+ PAUSE_coded ", dmpout
);
3583 fputc ('\n', dmpout
);
3585 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
3590 ffeste_emit_line_note_ ();
3593 || (ffeinfo_basictype (ffebld_info (expr
))
3594 == FFEINFO_basictypeANY
))
3596 msg
= ffelex_token_new_character ("", ffelex_token_where_line
3597 (ffesta_tokens
[0]), ffelex_token_where_column
3598 (ffesta_tokens
[0]));
3599 expr
= ffebld_new_conter (ffebld_constant_new_characterdefault
3601 ffelex_token_kill (msg
);
3602 ffebld_set_info (expr
, ffeinfo_new (FFEINFO_basictypeCHARACTER
,
3603 FFEINFO_kindtypeCHARACTERDEFAULT
, 0, FFEINFO_kindENTITY
,
3604 FFEINFO_whereCONSTANT
, 0));
3606 else if (ffeinfo_basictype (ffebld_info (expr
))
3607 == FFEINFO_basictypeINTEGER
)
3611 assert (ffebld_op (expr
) == FFEBLD_opCONTER
);
3612 assert (ffeinfo_kindtype (ffebld_info (expr
))
3613 == FFEINFO_kindtypeINTEGERDEFAULT
);
3614 sprintf (num
, "%" ffetargetIntegerDefault_f
"d",
3615 ffebld_constant_integer1 (ffebld_conter (expr
)));
3616 msg
= ffelex_token_new_character (num
, ffelex_token_where_line
3617 (ffesta_tokens
[0]), ffelex_token_where_column
3618 (ffesta_tokens
[0]));
3619 expr
= ffebld_new_conter (ffebld_constant_new_characterdefault
3621 ffelex_token_kill (msg
);
3622 ffebld_set_info (expr
, ffeinfo_new (FFEINFO_basictypeCHARACTER
,
3623 FFEINFO_kindtypeCHARACTERDEFAULT
, 0, FFEINFO_kindENTITY
,
3624 FFEINFO_whereCONSTANT
, 0));
3628 assert (ffeinfo_basictype (ffebld_info (expr
))
3629 == FFEINFO_basictypeCHARACTER
);
3630 assert (ffebld_op (expr
) == FFEBLD_opCONTER
);
3631 assert (ffeinfo_kindtype (ffebld_info (expr
))
3632 == FFEINFO_kindtypeCHARACTERDEFAULT
);
3635 /* No need to call ffeste_start_stmt_(), as the sorts of expressions
3636 seen here should never require use of temporaries. */
3638 callit
= ffecom_call_gfrt (FFECOM_gfrtPAUSE
,
3639 ffecom_list_ptr_to_expr (ffebld_new_item (expr
, NULL
)),
3641 TREE_SIDE_EFFECTS (callit
) = 1;
3643 expand_expr_stmt (callit
);
3647 #if 0 /* Old approach for phantom g77 run-time
3652 ffeste_emit_line_note_ ();
3655 callit
= ffecom_call_gfrt (FFECOM_gfrtPAUSENIL
, NULL_TREE
, NULL_TREE
);
3656 else if (ffeinfo_basictype (ffebld_info (expr
))
3657 == FFEINFO_basictypeINTEGER
)
3658 callit
= ffecom_call_gfrt (FFECOM_gfrtPAUSEINT
,
3659 ffecom_list_ptr_to_expr (ffebld_new_item (expr
, NULL
)),
3661 else if (ffeinfo_basictype (ffebld_info (expr
))
3662 == FFEINFO_basictypeCHARACTER
)
3663 callit
= ffecom_call_gfrt (FFECOM_gfrtPAUSECHAR
,
3664 ffecom_list_ptr_to_expr (ffebld_new_item (expr
, NULL
)),
3668 TREE_SIDE_EFFECTS (callit
) = 1;
3670 expand_expr_stmt (callit
);
3680 /* OPEN statement. */
3683 ffeste_R904 (ffestpOpenStmt
*info
)
3685 ffeste_check_simple_ ();
3687 #if FFECOM_targetCURRENT == FFECOM_targetFFE
3688 fputs ("+ OPEN (", dmpout
);
3689 ffeste_subr_file_ ("UNIT", &info
->open_spec
[FFESTP_openixUNIT
]);
3690 ffeste_subr_file_ ("ACCESS", &info
->open_spec
[FFESTP_openixACCESS
]);
3691 ffeste_subr_file_ ("ACTION", &info
->open_spec
[FFESTP_openixACTION
]);
3692 ffeste_subr_file_ ("ASSOCIATEVARIABLE", &info
->open_spec
[FFESTP_openixASSOCIATEVARIABLE
]);
3693 ffeste_subr_file_ ("BLANK", &info
->open_spec
[FFESTP_openixBLANK
]);
3694 ffeste_subr_file_ ("BLOCKSIZE", &info
->open_spec
[FFESTP_openixBLOCKSIZE
]);
3695 ffeste_subr_file_ ("BUFFERCOUNT", &info
->open_spec
[FFESTP_openixBUFFERCOUNT
]);
3696 ffeste_subr_file_ ("CARRIAGECONTROL", &info
->open_spec
[FFESTP_openixCARRIAGECONTROL
]);
3697 ffeste_subr_file_ ("DEFAULTFILE", &info
->open_spec
[FFESTP_openixDEFAULTFILE
]);
3698 ffeste_subr_file_ ("DELIM", &info
->open_spec
[FFESTP_openixDELIM
]);
3699 ffeste_subr_file_ ("DISPOSE", &info
->open_spec
[FFESTP_openixDISPOSE
]);
3700 ffeste_subr_file_ ("ERR", &info
->open_spec
[FFESTP_openixERR
]);
3701 ffeste_subr_file_ ("EXTENDSIZE", &info
->open_spec
[FFESTP_openixEXTENDSIZE
]);
3702 ffeste_subr_file_ ("FILE", &info
->open_spec
[FFESTP_openixFILE
]);
3703 ffeste_subr_file_ ("FORM", &info
->open_spec
[FFESTP_openixFORM
]);
3704 ffeste_subr_file_ ("INITIALSIZE", &info
->open_spec
[FFESTP_openixINITIALSIZE
]);
3705 ffeste_subr_file_ ("IOSTAT", &info
->open_spec
[FFESTP_openixIOSTAT
]);
3706 ffeste_subr_file_ ("KEY", &info
->open_spec
[FFESTP_openixKEY
]);
3707 ffeste_subr_file_ ("MAXREC", &info
->open_spec
[FFESTP_openixMAXREC
]);
3708 ffeste_subr_file_ ("NOSPANBLOCKS", &info
->open_spec
[FFESTP_openixNOSPANBLOCKS
]);
3709 ffeste_subr_file_ ("ORGANIZATION", &info
->open_spec
[FFESTP_openixORGANIZATION
]);
3710 ffeste_subr_file_ ("PAD", &info
->open_spec
[FFESTP_openixPAD
]);
3711 ffeste_subr_file_ ("POSITION", &info
->open_spec
[FFESTP_openixPOSITION
]);
3712 ffeste_subr_file_ ("READONLY", &info
->open_spec
[FFESTP_openixREADONLY
]);
3713 ffeste_subr_file_ ("RECL", &info
->open_spec
[FFESTP_openixRECL
]);
3714 ffeste_subr_file_ ("RECORDTYPE", &info
->open_spec
[FFESTP_openixRECORDTYPE
]);
3715 ffeste_subr_file_ ("SHARED", &info
->open_spec
[FFESTP_openixSHARED
]);
3716 ffeste_subr_file_ ("STATUS", &info
->open_spec
[FFESTP_openixSTATUS
]);
3717 ffeste_subr_file_ ("USEROPEN", &info
->open_spec
[FFESTP_openixUSEROPEN
]);
3718 fputs (")\n", dmpout
);
3719 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
3725 ffeste_emit_line_note_ ();
3727 #define specified(something) (info->open_spec[something].kw_or_val_present)
3729 iostat
= specified (FFESTP_openixIOSTAT
);
3730 errl
= specified (FFESTP_openixERR
);
3734 ffeste_start_stmt_ ();
3740 = ffecom_lookup_label
3741 (info
->open_spec
[FFESTP_openixERR
].u
.label
);
3742 ffeste_io_abort_is_temp_
= FALSE
;
3746 ffeste_io_err_
= NULL_TREE
;
3748 if ((ffeste_io_abort_is_temp_
= iostat
))
3749 ffeste_io_abort_
= ffecom_temp_label ();
3751 ffeste_io_abort_
= NULL_TREE
;
3756 /* Have IOSTAT= specification. */
3758 ffeste_io_iostat_is_temp_
= FALSE
;
3759 ffeste_io_iostat_
= ffecom_expr
3760 (info
->open_spec
[FFESTP_openixIOSTAT
].u
.expr
);
3762 else if (ffeste_io_abort_
!= NULL_TREE
)
3764 /* Have no IOSTAT= but have ERR=. */
3766 ffeste_io_iostat_is_temp_
= TRUE
;
3768 = ffecom_make_tempvar ("open", ffecom_integer_type_node
,
3769 FFETARGET_charactersizeNONE
, -1);
3773 /* No IOSTAT= or ERR= specification. */
3775 ffeste_io_iostat_is_temp_
= FALSE
;
3776 ffeste_io_iostat_
= NULL_TREE
;
3779 /* Now prescan, then convert, all the arguments. */
3781 args
= ffeste_io_olist_ (errl
|| iostat
,
3782 info
->open_spec
[FFESTP_openixUNIT
].u
.expr
,
3783 &info
->open_spec
[FFESTP_openixFILE
],
3784 &info
->open_spec
[FFESTP_openixSTATUS
],
3785 &info
->open_spec
[FFESTP_openixACCESS
],
3786 &info
->open_spec
[FFESTP_openixFORM
],
3787 &info
->open_spec
[FFESTP_openixRECL
],
3788 &info
->open_spec
[FFESTP_openixBLANK
]);
3790 /* Don't generate "if (iostat != 0) goto label;" if label is temp abort
3791 label, since we're gonna fall through to there anyway. */
3793 ffeste_io_call_ (ffecom_call_gfrt (FFECOM_gfrtFOPEN
, args
, NULL_TREE
),
3794 ! ffeste_io_abort_is_temp_
);
3796 /* If we've got a temp label, generate its code here. */
3798 if (ffeste_io_abort_is_temp_
)
3800 DECL_INITIAL (ffeste_io_abort_
) = error_mark_node
;
3802 expand_label (ffeste_io_abort_
);
3804 assert (ffeste_io_err_
== NULL_TREE
);
3807 ffeste_end_stmt_ ();
3814 /* CLOSE statement. */
3817 ffeste_R907 (ffestpCloseStmt
*info
)
3819 ffeste_check_simple_ ();
3821 #if FFECOM_targetCURRENT == FFECOM_targetFFE
3822 fputs ("+ CLOSE (", dmpout
);
3823 ffeste_subr_file_ ("UNIT", &info
->close_spec
[FFESTP_closeixUNIT
]);
3824 ffeste_subr_file_ ("ERR", &info
->close_spec
[FFESTP_closeixERR
]);
3825 ffeste_subr_file_ ("IOSTAT", &info
->close_spec
[FFESTP_closeixIOSTAT
]);
3826 ffeste_subr_file_ ("STATUS", &info
->close_spec
[FFESTP_closeixSTATUS
]);
3827 fputs (")\n", dmpout
);
3828 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
3834 ffeste_emit_line_note_ ();
3836 #define specified(something) (info->close_spec[something].kw_or_val_present)
3838 iostat
= specified (FFESTP_closeixIOSTAT
);
3839 errl
= specified (FFESTP_closeixERR
);
3843 ffeste_start_stmt_ ();
3849 = ffecom_lookup_label
3850 (info
->close_spec
[FFESTP_closeixERR
].u
.label
);
3851 ffeste_io_abort_is_temp_
= FALSE
;
3855 ffeste_io_err_
= NULL_TREE
;
3857 if ((ffeste_io_abort_is_temp_
= iostat
))
3858 ffeste_io_abort_
= ffecom_temp_label ();
3860 ffeste_io_abort_
= NULL_TREE
;
3865 /* Have IOSTAT= specification. */
3867 ffeste_io_iostat_is_temp_
= FALSE
;
3868 ffeste_io_iostat_
= ffecom_expr
3869 (info
->close_spec
[FFESTP_closeixIOSTAT
].u
.expr
);
3871 else if (ffeste_io_abort_
!= NULL_TREE
)
3873 /* Have no IOSTAT= but have ERR=. */
3875 ffeste_io_iostat_is_temp_
= TRUE
;
3877 = ffecom_make_tempvar ("close", ffecom_integer_type_node
,
3878 FFETARGET_charactersizeNONE
, -1);
3882 /* No IOSTAT= or ERR= specification. */
3884 ffeste_io_iostat_is_temp_
= FALSE
;
3885 ffeste_io_iostat_
= NULL_TREE
;
3888 /* Now prescan, then convert, all the arguments. */
3890 args
= ffeste_io_cllist_ (errl
|| iostat
,
3891 info
->close_spec
[FFESTP_closeixUNIT
].u
.expr
,
3892 &info
->close_spec
[FFESTP_closeixSTATUS
]);
3894 /* Don't generate "if (iostat != 0) goto label;" if label is temp abort
3895 label, since we're gonna fall through to there anyway. */
3897 ffeste_io_call_ (ffecom_call_gfrt (FFECOM_gfrtFCLOS
, args
, NULL_TREE
),
3898 ! ffeste_io_abort_is_temp_
);
3900 /* If we've got a temp label, generate its code here. */
3902 if (ffeste_io_abort_is_temp_
)
3904 DECL_INITIAL (ffeste_io_abort_
) = error_mark_node
;
3906 expand_label (ffeste_io_abort_
);
3908 assert (ffeste_io_err_
== NULL_TREE
);
3911 ffeste_end_stmt_ ();
3918 /* READ(...) statement -- start. */
3921 ffeste_R909_start (ffestpReadStmt
*info
, bool only_format UNUSED
,
3922 ffestvUnit unit
, ffestvFormat format
, bool rec
,
3925 ffeste_check_start_ ();
3927 #if FFECOM_targetCURRENT == FFECOM_targetFFE
3930 case FFESTV_formatNONE
:
3932 fputs ("+ READ_ufdac", dmpout
);
3934 fputs ("+ READ_ufidx", dmpout
);
3936 fputs ("+ READ_ufseq", dmpout
);
3939 case FFESTV_formatLABEL
:
3940 case FFESTV_formatCHAREXPR
:
3941 case FFESTV_formatINTEXPR
:
3943 fputs ("+ READ_fmdac", dmpout
);
3945 fputs ("+ READ_fmidx", dmpout
);
3946 else if (unit
== FFESTV_unitCHAREXPR
)
3947 fputs ("+ READ_fmint", dmpout
);
3949 fputs ("+ READ_fmseq", dmpout
);
3952 case FFESTV_formatASTERISK
:
3953 if (unit
== FFESTV_unitCHAREXPR
)
3954 fputs ("+ READ_lsint", dmpout
);
3956 fputs ("+ READ_lsseq", dmpout
);
3959 case FFESTV_formatNAMELIST
:
3960 fputs ("+ READ_nlseq", dmpout
);
3964 assert ("Unexpected kind of format item in R909 READ" == NULL
);
3969 fputc (' ', dmpout
);
3970 ffeste_subr_file_ ("FORMAT", &info
->read_spec
[FFESTP_readixFORMAT
]);
3971 fputc (' ', dmpout
);
3976 fputs (" (", dmpout
);
3977 ffeste_subr_file_ ("UNIT", &info
->read_spec
[FFESTP_readixUNIT
]);
3978 ffeste_subr_file_ ("FORMAT", &info
->read_spec
[FFESTP_readixFORMAT
]);
3979 ffeste_subr_file_ ("ADVANCE", &info
->read_spec
[FFESTP_readixADVANCE
]);
3980 ffeste_subr_file_ ("EOR", &info
->read_spec
[FFESTP_readixEOR
]);
3981 ffeste_subr_file_ ("ERR", &info
->read_spec
[FFESTP_readixERR
]);
3982 ffeste_subr_file_ ("END", &info
->read_spec
[FFESTP_readixEND
]);
3983 ffeste_subr_file_ ("IOSTAT", &info
->read_spec
[FFESTP_readixIOSTAT
]);
3984 ffeste_subr_file_ ("KEYEQ", &info
->read_spec
[FFESTP_readixKEYEQ
]);
3985 ffeste_subr_file_ ("KEYGE", &info
->read_spec
[FFESTP_readixKEYGE
]);
3986 ffeste_subr_file_ ("KEYGT", &info
->read_spec
[FFESTP_readixKEYGT
]);
3987 ffeste_subr_file_ ("KEYID", &info
->read_spec
[FFESTP_readixKEYID
]);
3988 ffeste_subr_file_ ("NULLS", &info
->read_spec
[FFESTP_readixNULLS
]);
3989 ffeste_subr_file_ ("REC", &info
->read_spec
[FFESTP_readixREC
]);
3990 ffeste_subr_file_ ("SIZE", &info
->read_spec
[FFESTP_readixSIZE
]);
3991 fputs (") ", dmpout
);
3992 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
3994 ffeste_emit_line_note_ ();
4004 /* First determine the start, per-item, and end run-time functions to
4005 call. The per-item function is picked by choosing an ffeste function
4006 to call to handle a given item; it knows how to generate a call to the
4007 appropriate run-time function, and is called an "I/O driver". */
4011 case FFESTV_formatNONE
: /* no FMT= */
4012 ffeste_io_driver_
= ffeste_io_douio_
;
4014 start
= FFECOM_gfrtSRDUE
, end
= FFECOM_gfrtERDUE
;
4017 start
= FFECOM_gfrtSRIUE
, end
= FFECOM_gfrtERIUE
;
4020 start
= FFECOM_gfrtSRSUE
, end
= FFECOM_gfrtERSUE
;
4023 case FFESTV_formatLABEL
: /* FMT=10 */
4024 case FFESTV_formatCHAREXPR
: /* FMT='(I10)' */
4025 case FFESTV_formatINTEXPR
: /* FMT=I [after ASSIGN 10 TO I] */
4026 ffeste_io_driver_
= ffeste_io_dofio_
;
4028 start
= FFECOM_gfrtSRDFE
, end
= FFECOM_gfrtERDFE
;
4031 start
= FFECOM_gfrtSRIFE
, end
= FFECOM_gfrtERIFE
;
4033 else if (unit
== FFESTV_unitCHAREXPR
)
4034 start
= FFECOM_gfrtSRSFI
, end
= FFECOM_gfrtERSFI
;
4036 start
= FFECOM_gfrtSRSFE
, end
= FFECOM_gfrtERSFE
;
4039 case FFESTV_formatASTERISK
: /* FMT=* */
4040 ffeste_io_driver_
= ffeste_io_dolio_
;
4041 if (unit
== FFESTV_unitCHAREXPR
)
4042 start
= FFECOM_gfrtSRSLI
, end
= FFECOM_gfrtERSLI
;
4044 start
= FFECOM_gfrtSRSLE
, end
= FFECOM_gfrtERSLE
;
4047 case FFESTV_formatNAMELIST
: /* FMT=FOO or NML=FOO [NAMELIST
4049 ffeste_io_driver_
= NULL
; /* No start or driver function. */
4050 start
= FFECOM_gfrtSRSNE
, end
= FFECOM_gfrt
;
4054 assert ("Weird stuff" == NULL
);
4055 start
= FFECOM_gfrt
, end
= FFECOM_gfrt
;
4058 ffeste_io_endgfrt_
= end
;
4060 #define specified(something) (info->read_spec[something].kw_or_val_present)
4062 iostat
= specified (FFESTP_readixIOSTAT
);
4063 errl
= specified (FFESTP_readixERR
);
4064 endl
= specified (FFESTP_readixEND
);
4068 ffeste_start_stmt_ ();
4072 /* Have ERR= specification. */
4075 = ffecom_lookup_label (info
->read_spec
[FFESTP_readixERR
].u
.label
);
4079 /* Have both ERR= and END=. Need a temp label to handle both. */
4081 = ffecom_lookup_label (info
->read_spec
[FFESTP_readixEND
].u
.label
);
4082 ffeste_io_abort_is_temp_
= TRUE
;
4083 ffeste_io_abort_
= ffecom_temp_label ();
4087 /* Have ERR= but no END=. */
4088 ffeste_io_end_
= NULL_TREE
;
4089 if ((ffeste_io_abort_is_temp_
= iostat
))
4090 ffeste_io_abort_
= ffecom_temp_label ();
4092 ffeste_io_abort_
= ffeste_io_err_
;
4097 /* No ERR= specification. */
4099 ffeste_io_err_
= NULL_TREE
;
4102 /* Have END= but no ERR=. */
4104 = ffecom_lookup_label (info
->read_spec
[FFESTP_readixEND
].u
.label
);
4105 if ((ffeste_io_abort_is_temp_
= iostat
))
4106 ffeste_io_abort_
= ffecom_temp_label ();
4108 ffeste_io_abort_
= ffeste_io_end_
;
4112 /* Have no ERR= or END=. */
4114 ffeste_io_end_
= NULL_TREE
;
4115 if ((ffeste_io_abort_is_temp_
= iostat
))
4116 ffeste_io_abort_
= ffecom_temp_label ();
4118 ffeste_io_abort_
= NULL_TREE
;
4124 /* Have IOSTAT= specification. */
4126 ffeste_io_iostat_is_temp_
= FALSE
;
4128 = ffecom_expr (info
->read_spec
[FFESTP_readixIOSTAT
].u
.expr
);
4130 else if (ffeste_io_abort_
!= NULL_TREE
)
4132 /* Have no IOSTAT= but have ERR= and/or END=. */
4134 ffeste_io_iostat_is_temp_
= TRUE
;
4136 = ffecom_make_tempvar ("read", ffecom_integer_type_node
,
4137 FFETARGET_charactersizeNONE
, -1);
4141 /* No IOSTAT=, ERR=, or END= specification. */
4143 ffeste_io_iostat_is_temp_
= FALSE
;
4144 ffeste_io_iostat_
= NULL_TREE
;
4147 /* Now prescan, then convert, all the arguments. */
4149 if (unit
== FFESTV_unitCHAREXPR
)
4150 cilist
= ffeste_io_icilist_ (errl
|| iostat
,
4151 info
->read_spec
[FFESTP_readixUNIT
].u
.expr
,
4152 endl
|| iostat
, format
,
4153 &info
->read_spec
[FFESTP_readixFORMAT
]);
4155 cilist
= ffeste_io_cilist_ (errl
|| iostat
, unit
,
4156 info
->read_spec
[FFESTP_readixUNIT
].u
.expr
,
4157 5, endl
|| iostat
, format
,
4158 &info
->read_spec
[FFESTP_readixFORMAT
],
4160 info
->read_spec
[FFESTP_readixREC
].u
.expr
);
4162 /* If there is no end function, then there are no item functions (i.e.
4163 it's a NAMELIST), and vice versa by the way. In this situation, don't
4164 generate the "if (iostat != 0) goto label;" if the label is temp abort
4165 label, since we're gonna fall through to there anyway. */
4167 ffeste_io_call_ (ffecom_call_gfrt (start
, cilist
, NULL_TREE
),
4168 (! ffeste_io_abort_is_temp_
) || (end
!= FFECOM_gfrt
));
4175 /* READ statement -- I/O item. */
4178 ffeste_R909_item (ffebld expr
, ffelexToken expr_token
)
4180 ffeste_check_item_ ();
4182 #if FFECOM_targetCURRENT == FFECOM_targetFFE
4184 fputc (',', dmpout
);
4185 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
4189 /* Strip parens off items such as in "READ *,(A)". This is really a bug
4190 in the user's code, but I've been told lots of code does this. */
4191 while (ffebld_op (expr
) == FFEBLD_opPAREN
)
4192 expr
= ffebld_left (expr
);
4194 if (ffebld_op (expr
) == FFEBLD_opANY
)
4197 if (ffebld_op (expr
) == FFEBLD_opIMPDO
)
4198 ffeste_io_impdo_ (expr
, expr_token
);
4201 ffeste_start_stmt_ ();
4203 ffecom_prepare_arg_ptr_to_expr (expr
);
4205 ffecom_prepare_end ();
4207 ffeste_io_call_ ((*ffeste_io_driver_
) (expr
), TRUE
);
4209 ffeste_end_stmt_ ();
4216 /* READ statement -- end. */
4219 ffeste_R909_finish ()
4221 ffeste_check_finish_ ();
4223 #if FFECOM_targetCURRENT == FFECOM_targetFFE
4224 fputc ('\n', dmpout
);
4225 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
4227 /* Don't generate "if (iostat != 0) goto label;" if label is temp abort
4228 label, since we're gonna fall through to there anyway. */
4230 if (ffeste_io_endgfrt_
!= FFECOM_gfrt
)
4231 ffeste_io_call_ (ffecom_call_gfrt (ffeste_io_endgfrt_
, NULL_TREE
,
4233 ! ffeste_io_abort_is_temp_
);
4235 /* If we've got a temp label, generate its code here and have it fan out
4236 to the END= or ERR= label as appropriate. */
4238 if (ffeste_io_abort_is_temp_
)
4240 DECL_INITIAL (ffeste_io_abort_
) = error_mark_node
;
4242 expand_label (ffeste_io_abort_
);
4244 /* "if (iostat<0) goto end_label;". */
4246 if ((ffeste_io_end_
!= NULL_TREE
)
4247 && (TREE_CODE (ffeste_io_end_
) != ERROR_MARK
))
4249 expand_start_cond (ffecom_truth_value
4250 (ffecom_2 (LT_EXPR
, integer_type_node
,
4252 ffecom_integer_zero_node
)),
4254 expand_goto (ffeste_io_end_
);
4258 /* "if (iostat>0) goto err_label;". */
4260 if ((ffeste_io_err_
!= NULL_TREE
)
4261 && (TREE_CODE (ffeste_io_err_
) != ERROR_MARK
))
4263 expand_start_cond (ffecom_truth_value
4264 (ffecom_2 (GT_EXPR
, integer_type_node
,
4266 ffecom_integer_zero_node
)),
4268 expand_goto (ffeste_io_err_
);
4273 ffeste_end_stmt_ ();
4279 /* WRITE statement -- start. */
4282 ffeste_R910_start (ffestpWriteStmt
*info
, ffestvUnit unit
,
4283 ffestvFormat format
, bool rec
)
4285 ffeste_check_start_ ();
4287 #if FFECOM_targetCURRENT == FFECOM_targetFFE
4290 case FFESTV_formatNONE
:
4292 fputs ("+ WRITE_ufdac (", dmpout
);
4294 fputs ("+ WRITE_ufseq_or_idx (", dmpout
);
4297 case FFESTV_formatLABEL
:
4298 case FFESTV_formatCHAREXPR
:
4299 case FFESTV_formatINTEXPR
:
4301 fputs ("+ WRITE_fmdac (", dmpout
);
4302 else if (unit
== FFESTV_unitCHAREXPR
)
4303 fputs ("+ WRITE_fmint (", dmpout
);
4305 fputs ("+ WRITE_fmseq_or_idx (", dmpout
);
4308 case FFESTV_formatASTERISK
:
4309 if (unit
== FFESTV_unitCHAREXPR
)
4310 fputs ("+ WRITE_lsint (", dmpout
);
4312 fputs ("+ WRITE_lsseq (", dmpout
);
4315 case FFESTV_formatNAMELIST
:
4316 fputs ("+ WRITE_nlseq (", dmpout
);
4320 assert ("Unexpected kind of format item in R910 WRITE" == NULL
);
4323 ffeste_subr_file_ ("UNIT", &info
->write_spec
[FFESTP_writeixUNIT
]);
4324 ffeste_subr_file_ ("FORMAT", &info
->write_spec
[FFESTP_writeixFORMAT
]);
4325 ffeste_subr_file_ ("ADVANCE", &info
->write_spec
[FFESTP_writeixADVANCE
]);
4326 ffeste_subr_file_ ("EOR", &info
->write_spec
[FFESTP_writeixEOR
]);
4327 ffeste_subr_file_ ("ERR", &info
->write_spec
[FFESTP_writeixERR
]);
4328 ffeste_subr_file_ ("IOSTAT", &info
->write_spec
[FFESTP_writeixIOSTAT
]);
4329 ffeste_subr_file_ ("REC", &info
->write_spec
[FFESTP_writeixREC
]);
4330 fputs (") ", dmpout
);
4331 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
4333 ffeste_emit_line_note_ ();
4342 /* First determine the start, per-item, and end run-time functions to
4343 call. The per-item function is picked by choosing an ffeste function
4344 to call to handle a given item; it knows how to generate a call to the
4345 appropriate run-time function, and is called an "I/O driver". */
4349 case FFESTV_formatNONE
: /* no FMT= */
4350 ffeste_io_driver_
= ffeste_io_douio_
;
4352 start
= FFECOM_gfrtSWDUE
, end
= FFECOM_gfrtEWDUE
;
4354 start
= FFECOM_gfrtSWSUE
, end
= FFECOM_gfrtEWSUE
;
4357 case FFESTV_formatLABEL
: /* FMT=10 */
4358 case FFESTV_formatCHAREXPR
: /* FMT='(I10)' */
4359 case FFESTV_formatINTEXPR
: /* FMT=I [after ASSIGN 10 TO I] */
4360 ffeste_io_driver_
= ffeste_io_dofio_
;
4362 start
= FFECOM_gfrtSWDFE
, end
= FFECOM_gfrtEWDFE
;
4363 else if (unit
== FFESTV_unitCHAREXPR
)
4364 start
= FFECOM_gfrtSWSFI
, end
= FFECOM_gfrtEWSFI
;
4366 start
= FFECOM_gfrtSWSFE
, end
= FFECOM_gfrtEWSFE
;
4369 case FFESTV_formatASTERISK
: /* FMT=* */
4370 ffeste_io_driver_
= ffeste_io_dolio_
;
4371 if (unit
== FFESTV_unitCHAREXPR
)
4372 start
= FFECOM_gfrtSWSLI
, end
= FFECOM_gfrtEWSLI
;
4374 start
= FFECOM_gfrtSWSLE
, end
= FFECOM_gfrtEWSLE
;
4377 case FFESTV_formatNAMELIST
: /* FMT=FOO or NML=FOO [NAMELIST
4379 ffeste_io_driver_
= NULL
; /* No start or driver function. */
4380 start
= FFECOM_gfrtSWSNE
, end
= FFECOM_gfrt
;
4384 assert ("Weird stuff" == NULL
);
4385 start
= FFECOM_gfrt
, end
= FFECOM_gfrt
;
4388 ffeste_io_endgfrt_
= end
;
4390 #define specified(something) (info->write_spec[something].kw_or_val_present)
4392 iostat
= specified (FFESTP_writeixIOSTAT
);
4393 errl
= specified (FFESTP_writeixERR
);
4397 ffeste_start_stmt_ ();
4399 ffeste_io_end_
= NULL_TREE
;
4403 /* Have ERR= specification. */
4407 = ffecom_lookup_label
4408 (info
->write_spec
[FFESTP_writeixERR
].u
.label
);
4409 ffeste_io_abort_is_temp_
= FALSE
;
4413 /* No ERR= specification. */
4415 ffeste_io_err_
= NULL_TREE
;
4417 if ((ffeste_io_abort_is_temp_
= iostat
))
4418 ffeste_io_abort_
= ffecom_temp_label ();
4420 ffeste_io_abort_
= NULL_TREE
;
4425 /* Have IOSTAT= specification. */
4427 ffeste_io_iostat_is_temp_
= FALSE
;
4428 ffeste_io_iostat_
= ffecom_expr
4429 (info
->write_spec
[FFESTP_writeixIOSTAT
].u
.expr
);
4431 else if (ffeste_io_abort_
!= NULL_TREE
)
4433 /* Have no IOSTAT= but have ERR=. */
4435 ffeste_io_iostat_is_temp_
= TRUE
;
4437 = ffecom_make_tempvar ("write", ffecom_integer_type_node
,
4438 FFETARGET_charactersizeNONE
, -1);
4442 /* No IOSTAT= or ERR= specification. */
4444 ffeste_io_iostat_is_temp_
= FALSE
;
4445 ffeste_io_iostat_
= NULL_TREE
;
4448 /* Now prescan, then convert, all the arguments. */
4450 if (unit
== FFESTV_unitCHAREXPR
)
4451 cilist
= ffeste_io_icilist_ (errl
|| iostat
,
4452 info
->write_spec
[FFESTP_writeixUNIT
].u
.expr
,
4454 &info
->write_spec
[FFESTP_writeixFORMAT
]);
4456 cilist
= ffeste_io_cilist_ (errl
|| iostat
, unit
,
4457 info
->write_spec
[FFESTP_writeixUNIT
].u
.expr
,
4459 &info
->write_spec
[FFESTP_writeixFORMAT
],
4461 info
->write_spec
[FFESTP_writeixREC
].u
.expr
);
4463 /* If there is no end function, then there are no item functions (i.e.
4464 it's a NAMELIST), and vice versa by the way. In this situation, don't
4465 generate the "if (iostat != 0) goto label;" if the label is temp abort
4466 label, since we're gonna fall through to there anyway. */
4468 ffeste_io_call_ (ffecom_call_gfrt (start
, cilist
, NULL_TREE
),
4469 (! ffeste_io_abort_is_temp_
) || (end
!= FFECOM_gfrt
));
4476 /* WRITE statement -- I/O item. */
4479 ffeste_R910_item (ffebld expr
, ffelexToken expr_token
)
4481 ffeste_check_item_ ();
4483 #if FFECOM_targetCURRENT == FFECOM_targetFFE
4485 fputc (',', dmpout
);
4486 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
4490 if (ffebld_op (expr
) == FFEBLD_opANY
)
4493 if (ffebld_op (expr
) == FFEBLD_opIMPDO
)
4494 ffeste_io_impdo_ (expr
, expr_token
);
4497 ffeste_start_stmt_ ();
4499 ffecom_prepare_arg_ptr_to_expr (expr
);
4501 ffecom_prepare_end ();
4503 ffeste_io_call_ ((*ffeste_io_driver_
) (expr
), TRUE
);
4505 ffeste_end_stmt_ ();
4512 /* WRITE statement -- end. */
4515 ffeste_R910_finish ()
4517 ffeste_check_finish_ ();
4519 #if FFECOM_targetCURRENT == FFECOM_targetFFE
4520 fputc ('\n', dmpout
);
4521 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
4523 /* Don't generate "if (iostat != 0) goto label;" if label is temp abort
4524 label, since we're gonna fall through to there anyway. */
4526 if (ffeste_io_endgfrt_
!= FFECOM_gfrt
)
4527 ffeste_io_call_ (ffecom_call_gfrt (ffeste_io_endgfrt_
, NULL_TREE
,
4529 ! ffeste_io_abort_is_temp_
);
4531 /* If we've got a temp label, generate its code here. */
4533 if (ffeste_io_abort_is_temp_
)
4535 DECL_INITIAL (ffeste_io_abort_
) = error_mark_node
;
4537 expand_label (ffeste_io_abort_
);
4539 assert (ffeste_io_err_
== NULL_TREE
);
4542 ffeste_end_stmt_ ();
4548 /* PRINT statement -- start. */
4551 ffeste_R911_start (ffestpPrintStmt
*info
, ffestvFormat format
)
4553 ffeste_check_start_ ();
4555 #if FFECOM_targetCURRENT == FFECOM_targetFFE
4558 case FFESTV_formatLABEL
:
4559 case FFESTV_formatCHAREXPR
:
4560 case FFESTV_formatINTEXPR
:
4561 fputs ("+ PRINT_fm ", dmpout
);
4564 case FFESTV_formatASTERISK
:
4565 fputs ("+ PRINT_ls ", dmpout
);
4568 case FFESTV_formatNAMELIST
:
4569 fputs ("+ PRINT_nl ", dmpout
);
4573 assert ("Unexpected kind of format item in R911 PRINT" == NULL
);
4575 ffeste_subr_file_ ("FORMAT", &info
->print_spec
[FFESTP_printixFORMAT
]);
4576 fputc (' ', dmpout
);
4577 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
4579 ffeste_emit_line_note_ ();
4586 /* First determine the start, per-item, and end run-time functions to
4587 call. The per-item function is picked by choosing an ffeste function
4588 to call to handle a given item; it knows how to generate a call to the
4589 appropriate run-time function, and is called an "I/O driver". */
4593 case FFESTV_formatLABEL
: /* FMT=10 */
4594 case FFESTV_formatCHAREXPR
: /* FMT='(I10)' */
4595 case FFESTV_formatINTEXPR
: /* FMT=I [after ASSIGN 10 TO I] */
4596 ffeste_io_driver_
= ffeste_io_dofio_
;
4597 start
= FFECOM_gfrtSWSFE
, end
= FFECOM_gfrtEWSFE
;
4600 case FFESTV_formatASTERISK
: /* FMT=* */
4601 ffeste_io_driver_
= ffeste_io_dolio_
;
4602 start
= FFECOM_gfrtSWSLE
, end
= FFECOM_gfrtEWSLE
;
4605 case FFESTV_formatNAMELIST
: /* FMT=FOO or NML=FOO [NAMELIST
4607 ffeste_io_driver_
= NULL
; /* No start or driver function. */
4608 start
= FFECOM_gfrtSWSNE
, end
= FFECOM_gfrt
;
4612 assert ("Weird stuff" == NULL
);
4613 start
= FFECOM_gfrt
, end
= FFECOM_gfrt
;
4616 ffeste_io_endgfrt_
= end
;
4618 ffeste_start_stmt_ ();
4620 ffeste_io_end_
= NULL_TREE
;
4621 ffeste_io_err_
= NULL_TREE
;
4622 ffeste_io_abort_
= NULL_TREE
;
4623 ffeste_io_abort_is_temp_
= FALSE
;
4624 ffeste_io_iostat_is_temp_
= FALSE
;
4625 ffeste_io_iostat_
= NULL_TREE
;
4627 /* Now prescan, then convert, all the arguments. */
4629 cilist
= ffeste_io_cilist_ (FALSE
, FFESTV_unitNONE
, NULL
, 6, FALSE
, format
,
4630 &info
->print_spec
[FFESTP_printixFORMAT
], FALSE
, NULL
);
4632 /* If there is no end function, then there are no item functions (i.e.
4633 it's a NAMELIST), and vice versa by the way. In this situation, don't
4634 generate the "if (iostat != 0) goto label;" if the label is temp abort
4635 label, since we're gonna fall through to there anyway. */
4637 ffeste_io_call_ (ffecom_call_gfrt (start
, cilist
, NULL_TREE
),
4638 (! ffeste_io_abort_is_temp_
) || (end
!= FFECOM_gfrt
));
4645 /* PRINT statement -- I/O item. */
4648 ffeste_R911_item (ffebld expr
, ffelexToken expr_token
)
4650 ffeste_check_item_ ();
4652 #if FFECOM_targetCURRENT == FFECOM_targetFFE
4654 fputc (',', dmpout
);
4655 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
4659 if (ffebld_op (expr
) == FFEBLD_opANY
)
4662 if (ffebld_op (expr
) == FFEBLD_opIMPDO
)
4663 ffeste_io_impdo_ (expr
, expr_token
);
4666 ffeste_start_stmt_ ();
4668 ffecom_prepare_arg_ptr_to_expr (expr
);
4670 ffecom_prepare_end ();
4672 ffeste_io_call_ ((*ffeste_io_driver_
) (expr
), TRUE
);
4674 ffeste_end_stmt_ ();
4681 /* PRINT statement -- end. */
4684 ffeste_R911_finish ()
4686 ffeste_check_finish_ ();
4688 #if FFECOM_targetCURRENT == FFECOM_targetFFE
4689 fputc ('\n', dmpout
);
4690 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
4692 if (ffeste_io_endgfrt_
!= FFECOM_gfrt
)
4693 ffeste_io_call_ (ffecom_call_gfrt (ffeste_io_endgfrt_
, NULL_TREE
,
4697 ffeste_end_stmt_ ();
4703 /* BACKSPACE statement. */
4706 ffeste_R919 (ffestpBeruStmt
*info
)
4708 ffeste_check_simple_ ();
4710 #if FFECOM_targetCURRENT == FFECOM_targetFFE
4711 fputs ("+ BACKSPACE (", dmpout
);
4712 ffeste_subr_file_ ("UNIT", &info
->beru_spec
[FFESTP_beruixUNIT
]);
4713 ffeste_subr_file_ ("ERR", &info
->beru_spec
[FFESTP_beruixERR
]);
4714 ffeste_subr_file_ ("IOSTAT", &info
->beru_spec
[FFESTP_beruixIOSTAT
]);
4715 fputs (")\n", dmpout
);
4716 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
4717 ffeste_subr_beru_ (info
, FFECOM_gfrtFBACK
);
4723 /* ENDFILE statement. */
4726 ffeste_R920 (ffestpBeruStmt
*info
)
4728 ffeste_check_simple_ ();
4730 #if FFECOM_targetCURRENT == FFECOM_targetFFE
4731 fputs ("+ ENDFILE (", dmpout
);
4732 ffeste_subr_file_ ("UNIT", &info
->beru_spec
[FFESTP_beruixUNIT
]);
4733 ffeste_subr_file_ ("ERR", &info
->beru_spec
[FFESTP_beruixERR
]);
4734 ffeste_subr_file_ ("IOSTAT", &info
->beru_spec
[FFESTP_beruixIOSTAT
]);
4735 fputs (")\n", dmpout
);
4736 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
4737 ffeste_subr_beru_ (info
, FFECOM_gfrtFEND
);
4743 /* REWIND statement. */
4746 ffeste_R921 (ffestpBeruStmt
*info
)
4748 ffeste_check_simple_ ();
4750 #if FFECOM_targetCURRENT == FFECOM_targetFFE
4751 fputs ("+ REWIND (", dmpout
);
4752 ffeste_subr_file_ ("UNIT", &info
->beru_spec
[FFESTP_beruixUNIT
]);
4753 ffeste_subr_file_ ("ERR", &info
->beru_spec
[FFESTP_beruixERR
]);
4754 ffeste_subr_file_ ("IOSTAT", &info
->beru_spec
[FFESTP_beruixIOSTAT
]);
4755 fputs (")\n", dmpout
);
4756 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
4757 ffeste_subr_beru_ (info
, FFECOM_gfrtFREW
);
4763 /* INQUIRE statement (non-IOLENGTH version). */
4766 ffeste_R923A (ffestpInquireStmt
*info
, bool by_file UNUSED
)
4768 ffeste_check_simple_ ();
4770 #if FFECOM_targetCURRENT == FFECOM_targetFFE
4773 fputs ("+ INQUIRE_file (", dmpout
);
4774 ffeste_subr_file_ ("FILE", &info
->inquire_spec
[FFESTP_inquireixFILE
]);
4778 fputs ("+ INQUIRE_unit (", dmpout
);
4779 ffeste_subr_file_ ("UNIT", &info
->inquire_spec
[FFESTP_inquireixUNIT
]);
4781 ffeste_subr_file_ ("ACCESS", &info
->inquire_spec
[FFESTP_inquireixACCESS
]);
4782 ffeste_subr_file_ ("ACTION", &info
->inquire_spec
[FFESTP_inquireixACTION
]);
4783 ffeste_subr_file_ ("BLANK", &info
->inquire_spec
[FFESTP_inquireixBLANK
]);
4784 ffeste_subr_file_ ("CARRIAGECONTROL", &info
->inquire_spec
[FFESTP_inquireixCARRIAGECONTROL
]);
4785 ffeste_subr_file_ ("DEFAULTFILE", &info
->inquire_spec
[FFESTP_inquireixDEFAULTFILE
]);
4786 ffeste_subr_file_ ("DELIM", &info
->inquire_spec
[FFESTP_inquireixDELIM
]);
4787 ffeste_subr_file_ ("DIRECT", &info
->inquire_spec
[FFESTP_inquireixDIRECT
]);
4788 ffeste_subr_file_ ("ERR", &info
->inquire_spec
[FFESTP_inquireixERR
]);
4789 ffeste_subr_file_ ("EXIST", &info
->inquire_spec
[FFESTP_inquireixEXIST
]);
4790 ffeste_subr_file_ ("FORM", &info
->inquire_spec
[FFESTP_inquireixFORM
]);
4791 ffeste_subr_file_ ("FORMATTED", &info
->inquire_spec
[FFESTP_inquireixFORMATTED
]);
4792 ffeste_subr_file_ ("IOSTAT", &info
->inquire_spec
[FFESTP_inquireixIOSTAT
]);
4793 ffeste_subr_file_ ("KEYED", &info
->inquire_spec
[FFESTP_inquireixKEYED
]);
4794 ffeste_subr_file_ ("NAME", &info
->inquire_spec
[FFESTP_inquireixNAME
]);
4795 ffeste_subr_file_ ("NAMED", &info
->inquire_spec
[FFESTP_inquireixNAMED
]);
4796 ffeste_subr_file_ ("NEXTREC", &info
->inquire_spec
[FFESTP_inquireixNEXTREC
]);
4797 ffeste_subr_file_ ("NUMBER", &info
->inquire_spec
[FFESTP_inquireixNUMBER
]);
4798 ffeste_subr_file_ ("OPENED", &info
->inquire_spec
[FFESTP_inquireixOPENED
]);
4799 ffeste_subr_file_ ("ORGANIZATION", &info
->inquire_spec
[FFESTP_inquireixORGANIZATION
]);
4800 ffeste_subr_file_ ("PAD", &info
->inquire_spec
[FFESTP_inquireixPAD
]);
4801 ffeste_subr_file_ ("POSITION", &info
->inquire_spec
[FFESTP_inquireixPOSITION
]);
4802 ffeste_subr_file_ ("READ", &info
->inquire_spec
[FFESTP_inquireixREAD
]);
4803 ffeste_subr_file_ ("READWRITE", &info
->inquire_spec
[FFESTP_inquireixREADWRITE
]);
4804 ffeste_subr_file_ ("RECL", &info
->inquire_spec
[FFESTP_inquireixRECL
]);
4805 ffeste_subr_file_ ("RECORDTYPE", &info
->inquire_spec
[FFESTP_inquireixRECORDTYPE
]);
4806 ffeste_subr_file_ ("SEQUENTIAL", &info
->inquire_spec
[FFESTP_inquireixSEQUENTIAL
]);
4807 ffeste_subr_file_ ("UNFORMATTED", &info
->inquire_spec
[FFESTP_inquireixUNFORMATTED
]);
4808 ffeste_subr_file_ ("WRITE", &info
->inquire_spec
[FFESTP_inquireixWRITE
]);
4809 fputs (")\n", dmpout
);
4810 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
4816 ffeste_emit_line_note_ ();
4818 #define specified(something) (info->inquire_spec[something].kw_or_val_present)
4820 iostat
= specified (FFESTP_inquireixIOSTAT
);
4821 errl
= specified (FFESTP_inquireixERR
);
4825 ffeste_start_stmt_ ();
4831 = ffecom_lookup_label
4832 (info
->inquire_spec
[FFESTP_inquireixERR
].u
.label
);
4833 ffeste_io_abort_is_temp_
= FALSE
;
4837 ffeste_io_err_
= NULL_TREE
;
4839 if ((ffeste_io_abort_is_temp_
= iostat
))
4840 ffeste_io_abort_
= ffecom_temp_label ();
4842 ffeste_io_abort_
= NULL_TREE
;
4847 /* Have IOSTAT= specification. */
4849 ffeste_io_iostat_is_temp_
= FALSE
;
4850 ffeste_io_iostat_
= ffecom_expr
4851 (info
->inquire_spec
[FFESTP_inquireixIOSTAT
].u
.expr
);
4853 else if (ffeste_io_abort_
!= NULL_TREE
)
4855 /* Have no IOSTAT= but have ERR=. */
4857 ffeste_io_iostat_is_temp_
= TRUE
;
4859 = ffecom_make_tempvar ("inquire", ffecom_integer_type_node
,
4860 FFETARGET_charactersizeNONE
, -1);
4864 /* No IOSTAT= or ERR= specification. */
4866 ffeste_io_iostat_is_temp_
= FALSE
;
4867 ffeste_io_iostat_
= NULL_TREE
;
4870 /* Now prescan, then convert, all the arguments. */
4873 = ffeste_io_inlist_ (errl
|| iostat
,
4874 &info
->inquire_spec
[FFESTP_inquireixUNIT
],
4875 &info
->inquire_spec
[FFESTP_inquireixFILE
],
4876 &info
->inquire_spec
[FFESTP_inquireixEXIST
],
4877 &info
->inquire_spec
[FFESTP_inquireixOPENED
],
4878 &info
->inquire_spec
[FFESTP_inquireixNUMBER
],
4879 &info
->inquire_spec
[FFESTP_inquireixNAMED
],
4880 &info
->inquire_spec
[FFESTP_inquireixNAME
],
4881 &info
->inquire_spec
[FFESTP_inquireixACCESS
],
4882 &info
->inquire_spec
[FFESTP_inquireixSEQUENTIAL
],
4883 &info
->inquire_spec
[FFESTP_inquireixDIRECT
],
4884 &info
->inquire_spec
[FFESTP_inquireixFORM
],
4885 &info
->inquire_spec
[FFESTP_inquireixFORMATTED
],
4886 &info
->inquire_spec
[FFESTP_inquireixUNFORMATTED
],
4887 &info
->inquire_spec
[FFESTP_inquireixRECL
],
4888 &info
->inquire_spec
[FFESTP_inquireixNEXTREC
],
4889 &info
->inquire_spec
[FFESTP_inquireixBLANK
]);
4891 /* Don't generate "if (iostat != 0) goto label;" if label is temp abort
4892 label, since we're gonna fall through to there anyway. */
4894 ffeste_io_call_ (ffecom_call_gfrt (FFECOM_gfrtFINQU
, args
, NULL_TREE
),
4895 ! ffeste_io_abort_is_temp_
);
4897 /* If we've got a temp label, generate its code here. */
4899 if (ffeste_io_abort_is_temp_
)
4901 DECL_INITIAL (ffeste_io_abort_
) = error_mark_node
;
4903 expand_label (ffeste_io_abort_
);
4905 assert (ffeste_io_err_
== NULL_TREE
);
4908 ffeste_end_stmt_ ();
4915 /* INQUIRE(IOLENGTH=expr) statement -- start. */
4918 ffeste_R923B_start (ffestpInquireStmt
*info UNUSED
)
4920 ffeste_check_start_ ();
4922 #if FFECOM_targetCURRENT == FFECOM_targetFFE
4923 fputs ("+ INQUIRE (", dmpout
);
4924 ffeste_subr_file_ ("IOLENGTH", &info
->inquire_spec
[FFESTP_inquireixIOLENGTH
]);
4925 fputs (") ", dmpout
);
4926 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
4927 assert ("INQUIRE(IOLENGTH=<var>) not implemented yet! ~~~" == NULL
);
4929 ffeste_emit_line_note_ ();
4935 /* INQUIRE(IOLENGTH=expr) statement -- I/O item. */
4938 ffeste_R923B_item (ffebld expr UNUSED
)
4940 ffeste_check_item_ ();
4942 #if FFECOM_targetCURRENT == FFECOM_targetFFE
4944 fputc (',', dmpout
);
4945 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
4951 /* INQUIRE(IOLENGTH=expr) statement -- end. */
4954 ffeste_R923B_finish ()
4956 ffeste_check_finish_ ();
4958 #if FFECOM_targetCURRENT == FFECOM_targetFFE
4959 fputc ('\n', dmpout
);
4960 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
4966 /* ffeste_R1001 -- FORMAT statement
4968 ffeste_R1001(format_list); */
4971 ffeste_R1001 (ffests s
)
4973 ffeste_check_simple_ ();
4975 #if FFECOM_targetCURRENT == FFECOM_targetFFE
4976 fprintf (dmpout
, "$ FORMAT %.*s\n", (int) ffests_length (s
), ffests_text (s
));
4977 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
4984 assert (ffeste_label_formatdef_
!= NULL
);
4986 ffeste_emit_line_note_ ();
4988 t
= build_string (ffests_length (s
), ffests_text (s
));
4991 = build_type_variant (build_array_type
4993 build_range_type (integer_type_node
,
4995 build_int_2 (ffests_length (s
),
4998 TREE_CONSTANT (t
) = 1;
4999 TREE_STATIC (t
) = 1;
5001 push_obstacks_nochange ();
5002 end_temporary_allocation ();
5004 var
= ffecom_lookup_label (ffeste_label_formatdef_
);
5005 if ((var
!= NULL_TREE
)
5006 && (TREE_CODE (var
) == VAR_DECL
))
5008 DECL_INITIAL (var
) = t
;
5009 maxindex
= build_int_2 (ffests_length (s
) - 1, 0);
5010 ttype
= TREE_TYPE (var
);
5011 TYPE_DOMAIN (ttype
) = build_range_type (integer_type_node
,
5014 if (!TREE_TYPE (maxindex
))
5015 TREE_TYPE (maxindex
) = TYPE_DOMAIN (ttype
);
5016 layout_type (ttype
);
5017 rest_of_decl_compilation (var
, NULL
, 1, 0);
5019 expand_decl_init (var
);
5022 resume_temporary_allocation ();
5025 ffeste_label_formatdef_
= NULL
;
5037 #if FFECOM_targetCURRENT == FFECOM_targetFFE
5038 fputs ("+ END_PROGRAM\n", dmpout
);
5039 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
5045 /* END BLOCK DATA. */
5050 #if FFECOM_targetCURRENT == FFECOM_targetFFE
5051 fputs ("* END_BLOCK_DATA\n", dmpout
);
5052 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
5058 /* CALL statement. */
5061 ffeste_R1212 (ffebld expr
)
5063 ffeste_check_simple_ ();
5065 #if FFECOM_targetCURRENT == FFECOM_targetFFE
5066 fputs ("+ CALL ", dmpout
);
5068 fputc ('\n', dmpout
);
5069 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
5071 ffebld args
= ffebld_right (expr
);
5073 ffebld labels
= NULL
; /* First in list of LABTERs. */
5074 ffebld prevlabels
= NULL
;
5075 ffebld prevargs
= NULL
;
5077 ffeste_emit_line_note_ ();
5079 /* Here we split the list at ffebld_right(expr) into two lists: one at
5080 ffebld_right(expr) consisting of all items that are not LABTERs, the
5081 other at labels consisting of all items that are LABTERs. Then, if
5082 the latter list is NULL, we have an ordinary call, else we have a call
5083 with alternate returns. */
5085 for (args
= ffebld_right (expr
); args
!= NULL
; args
= ffebld_trail (args
))
5087 if (((arg
= ffebld_head (args
)) == NULL
)
5088 || (ffebld_op (arg
) != FFEBLD_opLABTER
))
5090 if (prevargs
== NULL
)
5093 ffebld_set_right (expr
, args
);
5097 ffebld_set_trail (prevargs
, args
);
5103 if (prevlabels
== NULL
)
5105 prevlabels
= labels
= args
;
5109 ffebld_set_trail (prevlabels
, args
);
5114 if (prevlabels
== NULL
)
5117 ffebld_set_trail (prevlabels
, NULL
);
5118 if (prevargs
== NULL
)
5119 ffebld_set_right (expr
, NULL
);
5121 ffebld_set_trail (prevargs
, NULL
);
5123 ffeste_start_stmt_ ();
5125 /* No temporaries are actually needed at this level, but we go
5126 through the motions anyway, just to be sure in case they do
5127 get made. Temporaries needed for arguments should be in the
5128 scopes of inner blocks, and if clean-up actions are supported,
5129 such as CALL-ing an intrinsic that writes to an argument of one
5130 type when a variable of a different type is provided (requiring
5131 assignment to the variable from a temporary after the library
5132 routine returns), the clean-up must be done by the expression
5133 evaluator, generally, to handle alternate returns (which we hope
5134 won't ever be supported by intrinsics, but might be a similar
5135 issue, such as CALL-ing an F90-style subroutine with an INTERFACE
5136 block). That implies the expression evaluator will have to
5137 recognize the need for its own temporary anyway, meaning it'll
5138 construct a block within the one constructed here. */
5140 ffecom_prepare_expr (expr
);
5142 ffecom_prepare_end ();
5145 expand_expr_stmt (ffecom_expr (expr
));
5156 texpr
= ffecom_expr (expr
);
5157 expand_start_case (0, texpr
, TREE_TYPE (texpr
), "CALL statement");
5159 for (caseno
= 1, label
= labels
;
5161 ++caseno
, label
= ffebld_trail (label
))
5163 value
= build_int_2 (caseno
, 0);
5164 tlabel
= build_decl (LABEL_DECL
, NULL_TREE
, NULL_TREE
);
5166 pushok
= pushcase (value
, convert
, tlabel
, &duplicate
);
5167 assert (pushok
== 0);
5170 = ffecom_lookup_label (ffebld_labter (ffebld_head (label
)));
5171 if ((tlabel
== NULL_TREE
)
5172 || (TREE_CODE (tlabel
) == ERROR_MARK
))
5174 TREE_USED (tlabel
) = 1;
5175 expand_goto (tlabel
);
5178 expand_end_case (texpr
);
5181 ffeste_end_stmt_ ();
5193 #if FFECOM_targetCURRENT == FFECOM_targetFFE
5194 fputs ("+ END_FUNCTION\n", dmpout
);
5195 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
5201 /* END SUBROUTINE. */
5206 #if FFECOM_targetCURRENT == FFECOM_targetFFE
5207 fprintf (dmpout
, "+ END_SUBROUTINE\n");
5208 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
5214 /* ENTRY statement. */
5217 ffeste_R1226 (ffesymbol entry
)
5219 ffeste_check_simple_ ();
5221 #if FFECOM_targetCURRENT == FFECOM_targetFFE
5222 fprintf (dmpout
, "+ ENTRY %s", ffesymbol_text (entry
));
5223 if (ffesymbol_dummyargs (entry
) != NULL
)
5227 fputc ('(', dmpout
);
5228 for (argh
= ffesymbol_dummyargs (entry
);
5230 argh
= ffebld_trail (argh
))
5232 assert (ffebld_head (argh
) != NULL
);
5233 switch (ffebld_op (ffebld_head (argh
)))
5235 case FFEBLD_opSYMTER
:
5236 fputs (ffesymbol_text (ffebld_symter (ffebld_head (argh
))),
5241 fputc ('*', dmpout
);
5245 fputc ('?', dmpout
);
5246 ffebld_dump (ffebld_head (argh
));
5247 fputc ('?', dmpout
);
5250 if (ffebld_trail (argh
) != NULL
)
5251 fputc (',', dmpout
);
5253 fputc (')', dmpout
);
5255 fputc ('\n', dmpout
);
5256 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
5258 tree label
= ffesymbol_hook (entry
).length_tree
;
5260 ffeste_emit_line_note_ ();
5262 if (label
== error_mark_node
)
5265 DECL_INITIAL (label
) = error_mark_node
;
5267 expand_label (label
);
5274 /* RETURN statement. */
5277 ffeste_R1227 (ffestw block UNUSED
, ffebld expr
)
5279 ffeste_check_simple_ ();
5281 #if FFECOM_targetCURRENT == FFECOM_targetFFE
5284 fputs ("+ RETURN\n", dmpout
);
5288 fputs ("+ RETURN_alternate ", dmpout
);
5290 fputc ('\n', dmpout
);
5292 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
5296 ffeste_emit_line_note_ ();
5298 ffeste_start_stmt_ ();
5300 ffecom_prepare_return_expr (expr
);
5302 ffecom_prepare_end ();
5304 rtn
= ffecom_return_expr (expr
);
5306 if ((rtn
== NULL_TREE
)
5307 || (rtn
== error_mark_node
))
5308 expand_null_return ();
5311 tree result
= DECL_RESULT (current_function_decl
);
5313 if ((result
!= error_mark_node
)
5314 && (TREE_TYPE (result
) != error_mark_node
))
5315 expand_return (ffecom_modify (NULL_TREE
,
5317 convert (TREE_TYPE (result
),
5320 expand_null_return ();
5323 ffeste_end_stmt_ ();
5330 /* REWRITE statement -- start. */
5334 ffeste_V018_start (ffestpRewriteStmt
*info
, ffestvFormat format
)
5336 ffeste_check_start_ ();
5338 #if FFECOM_targetCURRENT == FFECOM_targetFFE
5341 case FFESTV_formatNONE
:
5342 fputs ("+ REWRITE_uf (", dmpout
);
5345 case FFESTV_formatLABEL
:
5346 case FFESTV_formatCHAREXPR
:
5347 case FFESTV_formatINTEXPR
:
5348 fputs ("+ REWRITE_fm (", dmpout
);
5352 assert ("Unexpected kind of format item in V018 REWRITE" == NULL
);
5354 ffeste_subr_file_ ("UNIT", &info
->rewrite_spec
[FFESTP_rewriteixUNIT
]);
5355 ffeste_subr_file_ ("FMT", &info
->rewrite_spec
[FFESTP_rewriteixFMT
]);
5356 ffeste_subr_file_ ("ERR", &info
->rewrite_spec
[FFESTP_rewriteixERR
]);
5357 ffeste_subr_file_ ("IOSTAT", &info
->rewrite_spec
[FFESTP_rewriteixIOSTAT
]);
5358 fputs (") ", dmpout
);
5359 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
5365 /* REWRITE statement -- I/O item. */
5368 ffeste_V018_item (ffebld expr
)
5370 ffeste_check_item_ ();
5372 #if FFECOM_targetCURRENT == FFECOM_targetFFE
5374 fputc (',', dmpout
);
5375 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
5381 /* REWRITE statement -- end. */
5384 ffeste_V018_finish ()
5386 ffeste_check_finish_ ();
5388 #if FFECOM_targetCURRENT == FFECOM_targetFFE
5389 fputc ('\n', dmpout
);
5390 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
5396 /* ACCEPT statement -- start. */
5399 ffeste_V019_start (ffestpAcceptStmt
*info
, ffestvFormat format
)
5401 ffeste_check_start_ ();
5403 #if FFECOM_targetCURRENT == FFECOM_targetFFE
5406 case FFESTV_formatLABEL
:
5407 case FFESTV_formatCHAREXPR
:
5408 case FFESTV_formatINTEXPR
:
5409 fputs ("+ ACCEPT_fm ", dmpout
);
5412 case FFESTV_formatASTERISK
:
5413 fputs ("+ ACCEPT_ls ", dmpout
);
5416 case FFESTV_formatNAMELIST
:
5417 fputs ("+ ACCEPT_nl ", dmpout
);
5421 assert ("Unexpected kind of format item in V019 ACCEPT" == NULL
);
5423 ffeste_subr_file_ ("FORMAT", &info
->accept_spec
[FFESTP_acceptixFORMAT
]);
5424 fputc (' ', dmpout
);
5425 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
5431 /* ACCEPT statement -- I/O item. */
5434 ffeste_V019_item (ffebld expr
)
5436 ffeste_check_item_ ();
5438 #if FFECOM_targetCURRENT == FFECOM_targetFFE
5440 fputc (',', dmpout
);
5441 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
5447 /* ACCEPT statement -- end. */
5450 ffeste_V019_finish ()
5452 ffeste_check_finish_ ();
5454 #if FFECOM_targetCURRENT == FFECOM_targetFFE
5455 fputc ('\n', dmpout
);
5456 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
5463 /* TYPE statement -- start. */
5466 ffeste_V020_start (ffestpTypeStmt
*info UNUSED
,
5467 ffestvFormat format UNUSED
)
5469 ffeste_check_start_ ();
5471 #if FFECOM_targetCURRENT == FFECOM_targetFFE
5474 case FFESTV_formatLABEL
:
5475 case FFESTV_formatCHAREXPR
:
5476 case FFESTV_formatINTEXPR
:
5477 fputs ("+ TYPE_fm ", dmpout
);
5480 case FFESTV_formatASTERISK
:
5481 fputs ("+ TYPE_ls ", dmpout
);
5484 case FFESTV_formatNAMELIST
:
5485 fputs ("* TYPE_nl ", dmpout
);
5489 assert ("Unexpected kind of format item in V020 TYPE" == NULL
);
5491 ffeste_subr_file_ ("FORMAT", &info
->type_spec
[FFESTP_typeixFORMAT
]);
5492 fputc (' ', dmpout
);
5493 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
5499 /* TYPE statement -- I/O item. */
5502 ffeste_V020_item (ffebld expr UNUSED
)
5504 ffeste_check_item_ ();
5506 #if FFECOM_targetCURRENT == FFECOM_targetFFE
5508 fputc (',', dmpout
);
5509 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
5515 /* TYPE statement -- end. */
5518 ffeste_V020_finish ()
5520 ffeste_check_finish_ ();
5522 #if FFECOM_targetCURRENT == FFECOM_targetFFE
5523 fputc ('\n', dmpout
);
5524 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
5530 /* DELETE statement. */
5534 ffeste_V021 (ffestpDeleteStmt
*info
)
5536 ffeste_check_simple_ ();
5538 #if FFECOM_targetCURRENT == FFECOM_targetFFE
5539 fputs ("+ DELETE (", dmpout
);
5540 ffeste_subr_file_ ("UNIT", &info
->delete_spec
[FFESTP_deleteixUNIT
]);
5541 ffeste_subr_file_ ("REC", &info
->delete_spec
[FFESTP_deleteixREC
]);
5542 ffeste_subr_file_ ("ERR", &info
->delete_spec
[FFESTP_deleteixERR
]);
5543 ffeste_subr_file_ ("IOSTAT", &info
->delete_spec
[FFESTP_deleteixIOSTAT
]);
5544 fputs (")\n", dmpout
);
5545 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
5551 /* UNLOCK statement. */
5554 ffeste_V022 (ffestpBeruStmt
*info
)
5556 ffeste_check_simple_ ();
5558 #if FFECOM_targetCURRENT == FFECOM_targetFFE
5559 fputs ("+ UNLOCK (", dmpout
);
5560 ffeste_subr_file_ ("UNIT", &info
->beru_spec
[FFESTP_beruixUNIT
]);
5561 ffeste_subr_file_ ("ERR", &info
->beru_spec
[FFESTP_beruixERR
]);
5562 ffeste_subr_file_ ("IOSTAT", &info
->beru_spec
[FFESTP_beruixIOSTAT
]);
5563 fputs (")\n", dmpout
);
5564 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
5570 /* ENCODE statement -- start. */
5573 ffeste_V023_start (ffestpVxtcodeStmt
*info
)
5575 ffeste_check_start_ ();
5577 #if FFECOM_targetCURRENT == FFECOM_targetFFE
5578 fputs ("+ ENCODE (", dmpout
);
5579 ffeste_subr_file_ ("C", &info
->vxtcode_spec
[FFESTP_vxtcodeixC
]);
5580 ffeste_subr_file_ ("F", &info
->vxtcode_spec
[FFESTP_vxtcodeixF
]);
5581 ffeste_subr_file_ ("B", &info
->vxtcode_spec
[FFESTP_vxtcodeixB
]);
5582 ffeste_subr_file_ ("ERR", &info
->vxtcode_spec
[FFESTP_vxtcodeixERR
]);
5583 ffeste_subr_file_ ("IOSTAT", &info
->vxtcode_spec
[FFESTP_vxtcodeixIOSTAT
]);
5584 fputs (") ", dmpout
);
5585 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
5591 /* ENCODE statement -- I/O item. */
5594 ffeste_V023_item (ffebld expr
)
5596 ffeste_check_item_ ();
5598 #if FFECOM_targetCURRENT == FFECOM_targetFFE
5600 fputc (',', dmpout
);
5601 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
5607 /* ENCODE statement -- end. */
5610 ffeste_V023_finish ()
5612 ffeste_check_finish_ ();
5614 #if FFECOM_targetCURRENT == FFECOM_targetFFE
5615 fputc ('\n', dmpout
);
5616 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
5622 /* DECODE statement -- start. */
5625 ffeste_V024_start (ffestpVxtcodeStmt
*info
)
5627 ffeste_check_start_ ();
5629 #if FFECOM_targetCURRENT == FFECOM_targetFFE
5630 fputs ("+ DECODE (", dmpout
);
5631 ffeste_subr_file_ ("C", &info
->vxtcode_spec
[FFESTP_vxtcodeixC
]);
5632 ffeste_subr_file_ ("F", &info
->vxtcode_spec
[FFESTP_vxtcodeixF
]);
5633 ffeste_subr_file_ ("B", &info
->vxtcode_spec
[FFESTP_vxtcodeixB
]);
5634 ffeste_subr_file_ ("ERR", &info
->vxtcode_spec
[FFESTP_vxtcodeixERR
]);
5635 ffeste_subr_file_ ("IOSTAT", &info
->vxtcode_spec
[FFESTP_vxtcodeixIOSTAT
]);
5636 fputs (") ", dmpout
);
5637 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
5643 /* DECODE statement -- I/O item. */
5646 ffeste_V024_item (ffebld expr
)
5648 ffeste_check_item_ ();
5650 #if FFECOM_targetCURRENT == FFECOM_targetFFE
5652 fputc (',', dmpout
);
5653 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
5659 /* DECODE statement -- end. */
5662 ffeste_V024_finish ()
5664 ffeste_check_finish_ ();
5666 #if FFECOM_targetCURRENT == FFECOM_targetFFE
5667 fputc ('\n', dmpout
);
5668 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
5674 /* DEFINEFILE statement -- start. */
5677 ffeste_V025_start ()
5679 ffeste_check_start_ ();
5681 #if FFECOM_targetCURRENT == FFECOM_targetFFE
5682 fputs ("+ DEFINE_FILE ", dmpout
);
5683 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
5689 /* DEFINE FILE statement -- item. */
5692 ffeste_V025_item (ffebld u
, ffebld m
, ffebld n
, ffebld asv
)
5694 ffeste_check_item_ ();
5696 #if FFECOM_targetCURRENT == FFECOM_targetFFE
5698 fputc ('(', dmpout
);
5700 fputc (',', dmpout
);
5702 fputs (",U,", dmpout
);
5704 fputs ("),", dmpout
);
5705 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
5711 /* DEFINE FILE statement -- end. */
5714 ffeste_V025_finish ()
5716 ffeste_check_finish_ ();
5718 #if FFECOM_targetCURRENT == FFECOM_targetFFE
5719 fputc ('\n', dmpout
);
5720 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
5726 /* FIND statement. */
5729 ffeste_V026 (ffestpFindStmt
*info
)
5731 ffeste_check_simple_ ();
5733 #if FFECOM_targetCURRENT == FFECOM_targetFFE
5734 fputs ("+ FIND (", dmpout
);
5735 ffeste_subr_file_ ("UNIT", &info
->find_spec
[FFESTP_findixUNIT
]);
5736 ffeste_subr_file_ ("REC", &info
->find_spec
[FFESTP_findixREC
]);
5737 ffeste_subr_file_ ("ERR", &info
->find_spec
[FFESTP_findixERR
]);
5738 ffeste_subr_file_ ("IOSTAT", &info
->find_spec
[FFESTP_findixIOSTAT
]);
5739 fputs (")\n", dmpout
);
5740 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
5748 #ifdef ENABLE_CHECKING
5750 ffeste_terminate_2 (void)
5752 assert (! ffeste_top_block_
);