?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
Daily bump.
[official-gcc.git] / gcc / f / ste.c
blobdbe48ddea4103f57130a91aa077ea050d87bb0f3
1 /* ste.c -- Implementation File (module.c template V1.0)
2 Copyright (C) 1995, 1996 Free Software Foundation, Inc.
3 Contributed by James Craig Burley.
4
5 This file is part of GNU Fortran.
6
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)
10 any later version.
11
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.
16
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
20 02111-1307, USA.
21
22 Related Modules:
23 ste.c
24
25 Description:
26 Implements the various statements and such like.
27
28 Modifications:
29 */
30
31 /* Include files. */
32
33 #include "proj.h"
34
35 #if FFECOM_targetCURRENT == FFECOM_targetGCC
36 #include "rtl.j"
37 #include "toplev.j"
38 #endif
39
40 #include "ste.h"
41 #include "bld.h"
42 #include "com.h"
43 #include "expr.h"
44 #include "lab.h"
45 #include "lex.h"
46 #include "sta.h"
47 #include "stp.h"
48 #include "str.h"
49 #include "sts.h"
50 #include "stt.h"
51 #include "stv.h"
52 #include "stw.h"
53 #include "symbol.h"
54
55 /* Externals defined here. */
56
57
58 /* Simple definitions and enumerations. */
59
60 typedef enum
61 {
62 FFESTE_stateletSIMPLE_, /* Expecting simple/start. */
63 FFESTE_stateletATTRIB_, /* Expecting attrib/item/itemstart. */
64 FFESTE_stateletITEM_, /* Expecting item/itemstart/finish. */
65 FFESTE_stateletITEMVALS_, /* Expecting itemvalue/itemendvals. */
66 FFESTE_
67 } ffesteStatelet_;
68
69 /* Internal typedefs. */
70
71
72 /* Private include files. */
73
74
75 /* Internal structure definitions. */
76
77
78 /* Static objects accessed by functions in this module. */
79
80 static ffesteStatelet_ ffeste_statelet_ = FFESTE_stateletSIMPLE_;
81 #if FFECOM_targetCURRENT == FFECOM_targetGCC
82 static ffelab ffeste_label_formatdef_ = NULL;
83 static tree (*ffeste_io_driver_) (ffebld expr); /* do?io. */
84 static ffecomGfrt ffeste_io_endgfrt_; /* end function to call. */
85 static tree ffeste_io_abort_; /* abort-io label or NULL_TREE. */
86 static bool ffeste_io_abort_is_temp_; /* abort-io label is a temp. */
87 static tree ffeste_io_end_; /* END= label or NULL_TREE. */
88 static tree ffeste_io_err_; /* ERR= label or NULL_TREE. */
89 static tree ffeste_io_iostat_; /* IOSTAT= var or NULL_TREE. */
90 static bool ffeste_io_iostat_is_temp_; /* IOSTAT= var is a temp. */
91 #endif
92
93 /* Static functions (internal). */
94
95 #if FFECOM_targetCURRENT == FFECOM_targetGCC
96 static void ffeste_begin_iterdo_ (ffestw block, tree *tvar, tree *tincr,
97 tree *xitersvar, ffebld var,
98 ffebld start, ffelexToken start_token,
99 ffebld end, ffelexToken end_token,
100 ffebld incr, ffelexToken incr_token,
101 const char *msg);
102 static void ffeste_end_iterdo_ (ffestw block, tree tvar, tree tincr,
103 tree itersvar);
104 static void ffeste_io_call_ (tree call, bool do_check);
105 static void ffeste_io_impdo_ (ffebld impdo, ffelexToken impdo_token);
106 static tree ffeste_io_dofio_ (ffebld expr);
107 static tree ffeste_io_dolio_ (ffebld expr);
108 static tree ffeste_io_douio_ (ffebld expr);
109 static tree ffeste_io_ialist_ (bool have_err, ffestvUnit unit,
110 ffebld unit_expr, int unit_dflt);
111 static tree ffeste_io_cilist_ (bool have_err, ffestvUnit unit,
112 ffebld unit_expr, int unit_dflt,
113 bool have_end, ffestvFormat format,
114 ffestpFile *format_spec, bool rec,
115 ffebld rec_expr);
116 static tree ffeste_io_cllist_ (bool have_err, ffebld unit_expr,
117 ffestpFile *stat_spec);
118 static tree ffeste_io_icilist_ (bool have_err, ffebld unit_expr,
119 bool have_end, ffestvFormat format,
120 ffestpFile *format_spec);
121 static tree ffeste_io_inlist_ (bool have_err,
122 ffestpFile *unit_spec,
123 ffestpFile *file_spec,
124 ffestpFile *exist_spec,
125 ffestpFile *open_spec,
126 ffestpFile *number_spec,
127 ffestpFile *named_spec,
128 ffestpFile *name_spec,
129 ffestpFile *access_spec,
130 ffestpFile *sequential_spec,
131 ffestpFile *direct_spec,
132 ffestpFile *form_spec,
133 ffestpFile *formatted_spec,
134 ffestpFile *unformatted_spec,
135 ffestpFile *recl_spec,
136 ffestpFile *nextrec_spec,
137 ffestpFile *blank_spec);
138 static tree ffeste_io_olist_ (bool have_err, ffebld unit_expr,
139 ffestpFile *file_spec,
140 ffestpFile *stat_spec,
141 ffestpFile *access_spec,
142 ffestpFile *form_spec,
143 ffestpFile *recl_spec,
144 ffestpFile *blank_spec);
145 static void ffeste_subr_beru_ (ffestpBeruStmt *info, ffecomGfrt rt);
146 #elif FFECOM_targetCURRENT == FFECOM_targetFFE
147 static void ffeste_subr_file_ (const char *kw, ffestpFile *spec);
148 #else
149 #error
150 #endif
151
152 /* Internal macros. */
153
154 #if FFECOM_targetCURRENT == FFECOM_targetGCC
155 #define ffeste_emit_line_note_() \
156 emit_line_note (input_filename, lineno)
157 #endif
158 #define ffeste_check_simple_() \
159 assert(ffeste_statelet_ == FFESTE_stateletSIMPLE_)
160 #define ffeste_check_start_() \
161 assert(ffeste_statelet_ == FFESTE_stateletSIMPLE_); \
162 ffeste_statelet_ = FFESTE_stateletATTRIB_
163 #define ffeste_check_attrib_() \
164 assert(ffeste_statelet_ == FFESTE_stateletATTRIB_)
165 #define ffeste_check_item_() \
166 assert(ffeste_statelet_ == FFESTE_stateletATTRIB_ \
167 || ffeste_statelet_ == FFESTE_stateletITEM_); \
168 ffeste_statelet_ = FFESTE_stateletITEM_
169 #define ffeste_check_item_startvals_() \
170 assert(ffeste_statelet_ == FFESTE_stateletATTRIB_ \
171 || ffeste_statelet_ == FFESTE_stateletITEM_); \
172 ffeste_statelet_ = FFESTE_stateletITEMVALS_
173 #define ffeste_check_item_value_() \
174 assert(ffeste_statelet_ == FFESTE_stateletITEMVALS_)
175 #define ffeste_check_item_endvals_() \
176 assert(ffeste_statelet_ == FFESTE_stateletITEMVALS_); \
177 ffeste_statelet_ = FFESTE_stateletITEM_
178 #define ffeste_check_finish_() \
179 assert(ffeste_statelet_ == FFESTE_stateletATTRIB_ \
180 || ffeste_statelet_ == FFESTE_stateletITEM_); \
181 ffeste_statelet_ = FFESTE_stateletSIMPLE_
182
183 #define ffeste_f2c_init_charnolen_(Exp,Init,Spec) \
184 do \
185 { \
186 if ((Spec)->kw_or_val_present) \
187 Exp = ffecom_arg_ptr_to_const_expr ((Spec)->u.expr, &ignore); \
188 else \
189 Exp = null_pointer_node; \
190 if (Exp) \
191 Init = Exp; \
192 else \
193 { \
194 Init = null_pointer_node; \
195 constantp = FALSE; \
196 } \
197 } while(0)
198
199 #define ffeste_f2c_init_char_(Exp,Init,Lenexp,Leninit,Spec) \
200 do \
201 { \
202 if ((Spec)->kw_or_val_present) \
203 Exp = ffecom_arg_ptr_to_const_expr ((Spec)->u.expr, &Lenexp); \
204 else \
205 { \
206 Exp = null_pointer_node; \
207 Lenexp = ffecom_f2c_ftnlen_zero_node; \
208 } \
209 if (Exp) \
210 Init = Exp; \
211 else \
212 { \
213 Init = null_pointer_node; \
214 constantp = FALSE; \
215 } \
216 if (Lenexp) \
217 Leninit = Lenexp; \
218 else \
219 { \
220 Leninit = ffecom_f2c_ftnlen_zero_node; \
221 constantp = FALSE; \
222 } \
223 } while(0)
224
225 #define ffeste_f2c_init_flag_(Flag,Init) \
226 do \
227 { \
228 Init = convert (ffecom_f2c_flag_type_node, \
229 (Flag) ? integer_one_node : integer_zero_node); \
230 } while(0)
231
232 #define ffeste_f2c_init_format_(Exp,Init,Spec) \
233 do \
234 { \
235 Exp = ffecom_arg_ptr_to_const_expr ((Spec)->u.expr, NULL); \
236 if (Exp) \
237 Init = Exp; \
238 else \
239 { \
240 Init = null_pointer_node; \
241 constantp = FALSE; \
242 } \
243 } while(0)
244
245 #define ffeste_f2c_init_int_(Exp,Init,Spec) \
246 do \
247 { \
248 if ((Spec)->kw_or_val_present) \
249 Exp = ffecom_const_expr ((Spec)->u.expr); \
250 else \
251 Exp = ffecom_integer_zero_node; \
252 if (Exp) \
253 Init = Exp; \
254 else \
255 { \
256 Init = ffecom_integer_zero_node; \
257 constantp = FALSE; \
258 } \
259 } while(0)
260
261 #define ffeste_f2c_init_ptrtoint_(Exp,Init,Spec) \
262 do \
263 { \
264 if ((Spec)->kw_or_val_present) \
265 Exp = ffecom_ptr_to_const_expr ((Spec)->u.expr); \
266 else \
267 Exp = null_pointer_node; \
268 if (Exp) \
269 Init = Exp; \
270 else \
271 { \
272 Init = null_pointer_node; \
273 constantp = FALSE; \
274 } \
275 } while(0)
276
277 #define ffeste_f2c_init_next_(Init) \
278 do \
279 { \
280 TREE_CHAIN (initn) = build_tree_list ((field = TREE_CHAIN (field)), \
281 (Init)); \
282 initn = TREE_CHAIN(initn); \
283 } while(0)
284
285 #define ffeste_f2c_prepare_charnolen_(Spec,Exp) \
286 do \
287 { \
288 if (! (Exp)) \
289 ffecom_prepare_arg_ptr_to_expr ((Spec)->u.expr); \
290 } while(0)
291
292 #define ffeste_f2c_prepare_char_(Spec,Exp) \
293 do \
294 { \
295 if (! (Exp)) \
296 ffecom_prepare_arg_ptr_to_expr ((Spec)->u.expr); \
297 } while(0)
298
299 #define ffeste_f2c_prepare_format_(Spec,Exp) \
300 do \
301 { \
302 if (! (Exp)) \
303 ffecom_prepare_arg_ptr_to_expr ((Spec)->u.expr); \
304 } while(0)
305
306 #define ffeste_f2c_prepare_int_(Spec,Exp) \
307 do \
308 { \
309 if (! (Exp)) \
310 ffecom_prepare_expr ((Spec)->u.expr); \
311 } while(0)
312
313 #define ffeste_f2c_prepare_ptrtoint_(Spec,Exp) \
314 do \
315 { \
316 if (! (Exp)) \
317 ffecom_prepare_ptr_to_expr ((Spec)->u.expr); \
318 } while(0)
319
320 #define ffeste_f2c_compile_(Field,Exp) \
321 do \
322 { \
323 tree exz; \
324 if ((Exp)) \
325 { \
326 exz = ffecom_modify (void_type_node, \
327 ffecom_2 (COMPONENT_REF, TREE_TYPE (Field), \
328 t, (Field)), \
329 (Exp)); \
330 expand_expr_stmt (exz); \
331 } \
332 } while(0)
333
334 #define ffeste_f2c_compile_charnolen_(Field,Spec,Exp) \
335 do \
336 { \
337 tree exq; \
338 if (! (Exp)) \
339 { \
340 exq = ffecom_arg_ptr_to_expr ((Spec)->u.expr, &ignore); \
341 ffeste_f2c_compile_ ((Field), exq); \
342 } \
343 } while(0)
344
345 #define ffeste_f2c_compile_char_(Field,Lenfield,Spec,Exp,Lenexp) \
346 do \
347 { \
348 tree exq = (Exp); \
349 tree lenexq = (Lenexp); \
350 int need_exq = (! exq); \
351 int need_lenexq = (! lenexq); \
352 if (need_exq || need_lenexq) \
353 { \
354 exq = ffecom_arg_ptr_to_expr ((Spec)->u.expr, &lenexq); \
355 if (need_exq) \
356 ffeste_f2c_compile_ ((Field), exq); \
357 if (need_lenexq) \
358 ffeste_f2c_compile_ ((Lenfield), lenexq); \
359 } \
360 } while(0)
361
362 #define ffeste_f2c_compile_format_(Field,Spec,Exp) \
363 do \
364 { \
365 tree exq; \
366 if (! (Exp)) \
367 { \
368 exq = ffecom_arg_ptr_to_expr ((Spec)->u.expr, NULL); \
369 ffeste_f2c_compile_ ((Field), exq); \
370 } \
371 } while(0)
372
373 #define ffeste_f2c_compile_int_(Field,Spec,Exp) \
374 do \
375 { \
376 tree exq; \
377 if (! (Exp)) \
378 { \
379 exq = ffecom_expr ((Spec)->u.expr); \
380 ffeste_f2c_compile_ ((Field), exq); \
381 } \
382 } while(0)
383
384 #define ffeste_f2c_compile_ptrtoint_(Field,Spec,Exp) \
385 do \
386 { \
387 tree exq; \
388 if (! (Exp)) \
389 { \
390 exq = ffecom_ptr_to_expr ((Spec)->u.expr); \
391 ffeste_f2c_compile_ ((Field), exq); \
392 } \
393 } while(0)
394 \f
395 /* Start a Fortran block. */
396
397 #ifdef ENABLE_CHECKING
398
399 typedef struct gbe_block
400 {
401 struct gbe_block *outer;
402 ffestw block;
403 int lineno;
404 char *input_filename;
405 bool is_stmt;
406 } *gbe_block;
407
408 gbe_block ffeste_top_block_ = NULL;
409
410 static void
411 ffeste_start_block_ (ffestw block)
412 {
413 gbe_block b = xmalloc (sizeof (*b));
414
415 b->outer = ffeste_top_block_;
416 b->block = block;
417 b->lineno = lineno;
418 b->input_filename = input_filename;
419 b->is_stmt = FALSE;
420
421 ffeste_top_block_ = b;
422
423 ffecom_start_compstmt ();
424 }
425
426 /* End a Fortran block. */
427
428 static void
429 ffeste_end_block_ (ffestw block)
430 {
431 gbe_block b = ffeste_top_block_;
432
433 assert (b);
434 assert (! b->is_stmt);
435 assert (b->block == block);
436 assert (! b->is_stmt);
437
438 ffeste_top_block_ = b->outer;
439
440 free (b);
441
442 clear_momentary ();
443
444 ffecom_end_compstmt ();
445 }
446
447 /* Start a Fortran statement.
448
449 Starts a back-end block, so temporaries can be managed, clean-ups
450 properly handled, etc. Nesting of statements *is* allowed -- the
451 handling of I/O items, even implied-DO I/O lists, within a READ,
452 PRINT, or WRITE statement is one example. */
453
454 static void
455 ffeste_start_stmt_(void)
456 {
457 gbe_block b = xmalloc (sizeof (*b));
458
459 b->outer = ffeste_top_block_;
460 b->block = NULL;
461 b->lineno = lineno;
462 b->input_filename = input_filename;
463 b->is_stmt = TRUE;
464
465 ffeste_top_block_ = b;
466
467 ffecom_start_compstmt ();
468 }
469
470 /* End a Fortran statement. */
471
472 static void
473 ffeste_end_stmt_(void)
474 {
475 gbe_block b = ffeste_top_block_;
476
477 assert (b);
478 assert (b->is_stmt);
479
480 ffeste_top_block_ = b->outer;
481
482 free (b);
483
484 clear_momentary ();
485
486 ffecom_end_compstmt ();
487 }
488
489 #else /* ! defined (ENABLE_CHECKING) */
490
491 #define ffeste_start_block_(b) ffecom_start_compstmt ()
492 #define ffeste_end_block_(b) \
493 do \
494 { \
495 clear_momentary (); \
496 ffecom_end_compstmt (); \
497 } while(0)
498 #define ffeste_start_stmt_() ffeste_start_block_(NULL)
499 #define ffeste_end_stmt_() ffeste_end_block_(NULL)
500
501 #endif /* ! defined (ENABLE_CHECKING) */
502
503 /* Begin an iterative DO loop. Pass the block to start if applicable.
504
505 NOTE: Does _two_ push_momentary () calls, which the caller must
506 undo (by calling ffeste_end_iterdo_). */
507
508 #if FFECOM_targetCURRENT == FFECOM_targetGCC
509 static void
510 ffeste_begin_iterdo_ (ffestw block, tree *xtvar, tree *xtincr,
511 tree *xitersvar, ffebld var,
512 ffebld start, ffelexToken start_token,
513 ffebld end, ffelexToken end_token,
514 ffebld incr, ffelexToken incr_token,
515 const char *msg)
516 {
517 tree tvar;
518 tree expr;
519 tree tstart;
520 tree tend;
521 tree tincr;
522 tree tincr_saved;
523 tree niters;
524 struct nesting *expanded_loop;
525
526 /* Want to have tvar, tincr, and niters for the whole loop body. */
527
528 if (block)
529 ffeste_start_block_ (block);
530 else
531 ffeste_start_stmt_ ();
532
533 niters = ffecom_make_tempvar (block ? "do" : "impdo",
534 ffecom_integer_type_node,
535 FFETARGET_charactersizeNONE, -1);
536
537 ffecom_prepare_expr (incr);
538 ffecom_prepare_expr_rw (NULL_TREE, var);
539
540 ffecom_prepare_end ();
541
542 tvar = ffecom_expr_rw (NULL_TREE, var);
543 tincr = ffecom_expr (incr);
544
545 if (TREE_CODE (tvar) == ERROR_MARK
546 || TREE_CODE (tincr) == ERROR_MARK)
547 {
548 if (block)
549 {
550 ffeste_end_block_ (block);
551 ffestw_set_do_tvar (block, error_mark_node);
552 }
553 else
554 {
555 ffeste_end_stmt_ ();
556 *xtvar = error_mark_node;
557 }
558 return;
559 }
560
561 /* Check whether incr is known to be zero, complain and fix. */
562
563 if (integer_zerop (tincr) || real_zerop (tincr))
564 {
565 ffebad_start (FFEBAD_DO_STEP_ZERO);
566 ffebad_here (0, ffelex_token_where_line (incr_token),
567 ffelex_token_where_column (incr_token));
568 ffebad_string (msg);
569 ffebad_finish ();
570 tincr = convert (TREE_TYPE (tvar), integer_one_node);
571 }
572
573 tincr_saved = ffecom_save_tree (tincr);
574
575 preserve_momentary ();
576
577 /* Want to have tstart, tend for just this statement. */
578
579 ffeste_start_stmt_ ();
580
581 ffecom_prepare_expr (start);
582 ffecom_prepare_expr (end);
583
584 ffecom_prepare_end ();
585
586 tstart = ffecom_expr (start);
587 tend = ffecom_expr (end);
588
589 if (TREE_CODE (tstart) == ERROR_MARK
590 || TREE_CODE (tend) == ERROR_MARK)
591 {
592 ffeste_end_stmt_ ();
593
594 if (block)
595 {
596 ffeste_end_block_ (block);
597 ffestw_set_do_tvar (block, error_mark_node);
598 }
599 else
600 {
601 ffeste_end_stmt_ ();
602 *xtvar = error_mark_node;
603 }
604 return;
605 }
606
607 /* For warnings only, nothing else happens here. */
608 {
609 tree try;
610
611 if (! ffe_is_onetrip ())
612 {
613 try = ffecom_2 (MINUS_EXPR, TREE_TYPE (tvar),
614 tend,
615 tstart);
616
617 try = ffecom_2 (PLUS_EXPR, TREE_TYPE (tvar),
618 try,
619 tincr);
620
621 if (TREE_CODE (TREE_TYPE (tvar)) != REAL_TYPE)
622 try = ffecom_2 (TRUNC_DIV_EXPR, integer_type_node, try,
623 tincr);
624 else
625 try = convert (integer_type_node,
626 ffecom_2 (RDIV_EXPR, TREE_TYPE (tvar),
627 try,
628 tincr));
629
630 /* Warn if loop never executed, since we've done the evaluation
631 of the unofficial iteration count already. */
632
633 try = ffecom_truth_value (ffecom_2 (LE_EXPR, integer_type_node,
634 try,
635 convert (TREE_TYPE (tvar),
636 integer_zero_node)));
637
638 if (integer_onep (try))
639 {
640 ffebad_start (FFEBAD_DO_NULL);
641 ffebad_here (0, ffelex_token_where_line (start_token),
642 ffelex_token_where_column (start_token));
643 ffebad_string (msg);
644 ffebad_finish ();
645 }
646 }
647
648 /* Warn if end plus incr would overflow. */
649
650 try = ffecom_2 (PLUS_EXPR, TREE_TYPE (tvar),
651 tend,
652 tincr);
653
654 if ((TREE_CODE_CLASS (TREE_CODE (try)) == 'c')
655 && TREE_CONSTANT_OVERFLOW (try))
656 {
657 ffebad_start (FFEBAD_DO_END_OVERFLOW);
658 ffebad_here (0, ffelex_token_where_line (end_token),
659 ffelex_token_where_column (end_token));
660 ffebad_string (msg);
661 ffebad_finish ();
662 }
663 }
664
665 /* Do the initial assignment into the DO var. */
666
667 tstart = ffecom_save_tree (tstart);
668
669 expr = ffecom_2 (MINUS_EXPR, TREE_TYPE (tvar),
670 tend,
671 tstart);
672
673 if (! ffe_is_onetrip ())
674 {
675 expr = ffecom_2 (PLUS_EXPR, TREE_TYPE (expr),
676 expr,
677 convert (TREE_TYPE (expr), tincr_saved));
678 }
679
680 if (TREE_CODE (TREE_TYPE (tvar)) != REAL_TYPE)
681 expr = ffecom_2 (TRUNC_DIV_EXPR, TREE_TYPE (expr),
682 expr,
683 tincr_saved);
684 else
685 expr = ffecom_2 (RDIV_EXPR, TREE_TYPE (expr),
686 expr,
687 tincr_saved);
688
689 #if 1 /* New, F90-approved approach: convert to default INTEGER. */
690 if (TREE_TYPE (tvar) != error_mark_node)
691 expr = convert (ffecom_integer_type_node, expr);
692 #else /* Old approach; convert to INTEGER unless that's a narrowing. */
693 if ((TREE_TYPE (tvar) != error_mark_node)
694 && ((TREE_CODE (TREE_TYPE (tvar)) != INTEGER_TYPE)
695 || ((TYPE_SIZE (TREE_TYPE (tvar)) != NULL_TREE)
696 && ((TREE_CODE (TYPE_SIZE (TREE_TYPE (tvar)))
697 != INTEGER_CST)
698 || (TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (tvar)))
699 <= TREE_INT_CST_LOW (TYPE_SIZE (ffecom_integer_type_node)))))))
700 /* Convert unless promoting INTEGER type of any kind downward to
701 default INTEGER; else leave as, say, INTEGER*8 (long long int). */
702 expr = convert (ffecom_integer_type_node, expr);
703 #endif
704
705 assert (TYPE_MAIN_VARIANT (TREE_TYPE (niters))
706 == TYPE_MAIN_VARIANT (TREE_TYPE (expr)));
707
708 expr = ffecom_modify (void_type_node, niters, expr);
709 expand_expr_stmt (expr);
710
711 expr = ffecom_modify (void_type_node, tvar, tstart);
712 expand_expr_stmt (expr);
713
714 ffeste_end_stmt_ ();
715
716 expanded_loop = expand_start_loop_continue_elsewhere (!! block);
717 if (block)
718 ffestw_set_do_hook (block, expanded_loop);
719
720 if (! ffe_is_onetrip ())
721 {
722 expr = ffecom_truth_value
723 (ffecom_2 (GE_EXPR, integer_type_node,
724 ffecom_2 (PREDECREMENT_EXPR,
725 TREE_TYPE (niters),
726 niters,
727 convert (TREE_TYPE (niters),
728 ffecom_integer_one_node)),
729 convert (TREE_TYPE (niters),
730 ffecom_integer_zero_node)));
731
732 expand_exit_loop_if_false (0, expr);
733 }
734
735 if (block)
736 {
737 ffestw_set_do_tvar (block, tvar);
738 ffestw_set_do_incr_saved (block, tincr_saved);
739 ffestw_set_do_count_var (block, niters);
740 }
741 else
742 {
743 *xtvar = tvar;
744 *xtincr = tincr_saved;
745 *xitersvar = niters;
746 }
747 }
748
749 #endif
750
751 /* End an iterative DO loop. Pass the same iteration variable and increment
752 value trees that were generated in the paired _begin_ call. */
753
754 #if FFECOM_targetCURRENT == FFECOM_targetGCC
755 static void
756 ffeste_end_iterdo_ (ffestw block, tree tvar, tree tincr, tree itersvar)
757 {
758 tree expr;
759 tree niters = itersvar;
760
761 if (tvar == error_mark_node)
762 return;
763
764 expand_loop_continue_here ();
765
766 ffeste_start_stmt_ ();
767
768 if (ffe_is_onetrip ())
769 {
770 expr = ffecom_truth_value
771 (ffecom_2 (GE_EXPR, integer_type_node,
772 ffecom_2 (PREDECREMENT_EXPR,
773 TREE_TYPE (niters),
774 niters,
775 convert (TREE_TYPE (niters),
776 ffecom_integer_one_node)),
777 convert (TREE_TYPE (niters),
778 ffecom_integer_zero_node)));
779
780 expand_exit_loop_if_false (0, expr);
781 }
782
783 expr = ffecom_modify (void_type_node, tvar,
784 ffecom_2 (PLUS_EXPR, TREE_TYPE (tvar),
785 tvar,
786 tincr));
787 expand_expr_stmt (expr);
788
789 /* Lose the stuff we just built. */
790 ffeste_end_stmt_ ();
791
792 expand_end_loop ();
793
794 /* Lose the tvar and incr_saved trees. */
795 if (block)
796 ffeste_end_block_ (block);
797 else
798 ffeste_end_stmt_ ();
799 }
800 #endif
801
802 /* Generate call to run-time I/O routine. */
803
804 #if FFECOM_targetCURRENT == FFECOM_targetGCC
805 static void
806 ffeste_io_call_ (tree call, bool do_check)
807 {
808 /* Generate the call and optional assignment into iostat var. */
809
810 TREE_SIDE_EFFECTS (call) = 1;
811 if (ffeste_io_iostat_ != NULL_TREE)
812 call = ffecom_modify (do_check ? NULL_TREE : void_type_node,
813 ffeste_io_iostat_, call);
814 expand_expr_stmt (call);
815
816 if (! do_check
817 || ffeste_io_abort_ == NULL_TREE
818 || TREE_CODE (ffeste_io_abort_) == ERROR_MARK)
819 return;
820
821 /* Generate optional test. */
822
823 expand_start_cond (ffecom_truth_value (ffeste_io_iostat_), 0);
824 expand_goto (ffeste_io_abort_);
825 expand_end_cond ();
826 }
827 #endif
828
829 /* Handle implied-DO in I/O list.
830
831 Expands code to start up the DO loop. Then for each item in the
832 DO loop, handles appropriately (possibly including recursively calling
833 itself). Then expands code to end the DO loop. */
834
835 #if FFECOM_targetCURRENT == FFECOM_targetGCC
836 static void
837 ffeste_io_impdo_ (ffebld impdo, ffelexToken impdo_token)
838 {
839 ffebld var = ffebld_head (ffebld_right (impdo));
840 ffebld start = ffebld_head (ffebld_trail (ffebld_right (impdo)));
841 ffebld end = ffebld_head (ffebld_trail (ffebld_trail
842 (ffebld_right (impdo))));
843 ffebld incr = ffebld_head (ffebld_trail (ffebld_trail
844 (ffebld_trail (ffebld_right (impdo)))));
845 ffebld list;
846 ffebld item;
847 tree tvar;
848 tree tincr;
849 tree titervar;
850
851 if (incr == NULL)
852 {
853 incr = ffebld_new_conter (ffebld_constant_new_integerdefault_val (1));
854 ffebld_set_info (incr, ffeinfo_new
855 (FFEINFO_basictypeINTEGER,
856 FFEINFO_kindtypeINTEGERDEFAULT,
857 0,
858 FFEINFO_kindENTITY,
859 FFEINFO_whereCONSTANT,
860 FFETARGET_charactersizeNONE));
861 }
862
863 /* Start the DO loop. */
864
865 start = ffeexpr_convert_expr (start, impdo_token, var, impdo_token,
866 FFEEXPR_contextLET);
867 end = ffeexpr_convert_expr (end, impdo_token, var, impdo_token,
868 FFEEXPR_contextLET);
869 incr = ffeexpr_convert_expr (incr, impdo_token, var, impdo_token,
870 FFEEXPR_contextLET);
871
872 ffeste_begin_iterdo_ (NULL, &tvar, &tincr, &titervar, var,
873 start, impdo_token,
874 end, impdo_token,
875 incr, impdo_token,
876 "Implied DO loop");
877
878 /* Handle the list of items. */
879
880 for (list = ffebld_left (impdo); list != NULL; list = ffebld_trail (list))
881 {
882 item = ffebld_head (list);
883 if (item == NULL)
884 continue;
885
886 /* Strip parens off items such as in "READ *,(A)". This is really a bug
887 in the user's code, but I've been told lots of code does this. */
888 while (ffebld_op (item) == FFEBLD_opPAREN)
889 item = ffebld_left (item);
890
891 if (ffebld_op (item) == FFEBLD_opANY)
892 continue;
893
894 if (ffebld_op (item) == FFEBLD_opIMPDO)
895 ffeste_io_impdo_ (item, impdo_token);
896 else
897 {
898 ffeste_start_stmt_ ();
899
900 ffecom_prepare_arg_ptr_to_expr (item);
901
902 ffecom_prepare_end ();
903
904 ffeste_io_call_ ((*ffeste_io_driver_) (item), TRUE);
905
906 ffeste_end_stmt_ ();
907 }
908 }
909
910 /* Generate end of implied-do construct. */
911
912 ffeste_end_iterdo_ (NULL, tvar, tincr, titervar);
913 }
914 #endif
915
916 /* I/O driver for formatted I/O item (do_fio)
917
918 Returns a tree for a CALL_EXPR to the do_fio function, which handles
919 a formatted I/O list item, along with the appropriate arguments for
920 the function. It is up to the caller to set the TREE_SIDE_EFFECTS flag
921 for the CALL_EXPR, expand (emit) the expression, emit any assignment
922 of the result to an IOSTAT= variable, and emit any checking of the
923 result for errors. */
924
925 #if FFECOM_targetCURRENT == FFECOM_targetGCC
926 static tree
927 ffeste_io_dofio_ (ffebld expr)
928 {
929 tree num_elements;
930 tree variable;
931 tree size;
932 tree arglist;
933 ffeinfoBasictype bt;
934 ffeinfoKindtype kt;
935 bool is_complex;
936
937 bt = ffeinfo_basictype (ffebld_info (expr));
938 kt = ffeinfo_kindtype (ffebld_info (expr));
939
940 if ((bt == FFEINFO_basictypeANY)
941 || (kt == FFEINFO_kindtypeANY))
942 return error_mark_node;
943
944 if (bt == FFEINFO_basictypeCOMPLEX)
945 {
946 is_complex = TRUE;
947 bt = FFEINFO_basictypeREAL;
948 }
949 else
950 is_complex = FALSE;
951
952 variable = ffecom_arg_ptr_to_expr (expr, &size);
953
954 if ((variable == error_mark_node)
955 || (size == error_mark_node))
956 return error_mark_node;
957
958 if (size == NULL_TREE) /* Already filled in for CHARACTER type. */
959 { /* "(ftnlen) sizeof(type)" */
960 size = size_binop (CEIL_DIV_EXPR,
961 TYPE_SIZE (ffecom_tree_type[bt][kt]),
962 size_int (TYPE_PRECISION (char_type_node)));
963 #if 0 /* Assume that while it is possible that char * is wider than
964 ftnlen, no object in Fortran space can get big enough for its
965 size to be wider than ftnlen. I really hope nobody wastes
966 time debugging a case where it can! */
967 assert (TYPE_PRECISION (ffecom_f2c_ftnlen_type_node)
968 >= TYPE_PRECISION (TREE_TYPE (size)));
969 #endif
970 size = convert (ffecom_f2c_ftnlen_type_node, size);
971 }
972
973 if (ffeinfo_rank (ffebld_info (expr)) == 0
974 || TREE_CODE (TREE_TYPE (TREE_TYPE (variable))) != ARRAY_TYPE)
975 num_elements
976 = is_complex ? ffecom_f2c_ftnlen_two_node : ffecom_f2c_ftnlen_one_node;
977 else
978 {
979 num_elements = size_binop (CEIL_DIV_EXPR,
980 TYPE_SIZE (TREE_TYPE (TREE_TYPE (variable))),
981 size);
982 num_elements = size_binop (CEIL_DIV_EXPR,
983 num_elements,
984 size_int (TYPE_PRECISION
985 (char_type_node)));
986 num_elements = convert (ffecom_f2c_ftnlen_type_node,
987 num_elements);
988 }
989
990 num_elements
991 = ffecom_1 (ADDR_EXPR, ffecom_f2c_ptr_to_ftnlen_type_node,
992 num_elements);
993
994 variable = convert (string_type_node, variable);
995
996 arglist = build_tree_list (NULL_TREE, num_elements);
997 TREE_CHAIN (arglist) = build_tree_list (NULL_TREE, variable);
998 TREE_CHAIN (TREE_CHAIN (arglist)) = build_tree_list (NULL_TREE, size);
999
1000 return ffecom_call_gfrt (FFECOM_gfrtDOFIO, arglist, NULL_TREE);
1001 }
1002
1003 #endif
1004 /* I/O driver for list-directed I/O item (do_lio)
1005
1006 Returns a tree for a CALL_EXPR to the do_lio function, which handles
1007 a list-directed I/O list item, along with the appropriate arguments for
1008 the function. It is up to the caller to set the TREE_SIDE_EFFECTS flag
1009 for the CALL_EXPR, expand (emit) the expression, emit any assignment
1010 of the result to an IOSTAT= variable, and emit any checking of the
1011 result for errors. */
1012
1013 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1014 static tree
1015 ffeste_io_dolio_ (ffebld expr)
1016 {
1017 tree type_id;
1018 tree num_elements;
1019 tree variable;
1020 tree size;
1021 tree arglist;
1022 ffeinfoBasictype bt;
1023 ffeinfoKindtype kt;
1024 int tc;
1025
1026 bt = ffeinfo_basictype (ffebld_info (expr));
1027 kt = ffeinfo_kindtype (ffebld_info (expr));
1028
1029 if ((bt == FFEINFO_basictypeANY)
1030 || (kt == FFEINFO_kindtypeANY))
1031 return error_mark_node;
1032
1033 tc = ffecom_f2c_typecode (bt, kt);
1034 assert (tc != -1);
1035 type_id = build_int_2 (tc, 0);
1036
1037 type_id
1038 = ffecom_1 (ADDR_EXPR, ffecom_f2c_ptr_to_ftnint_type_node,
1039 convert (ffecom_f2c_ftnint_type_node,
1040 type_id));
1041
1042 variable = ffecom_arg_ptr_to_expr (expr, &size);
1043
1044 if ((type_id == error_mark_node)
1045 || (variable == error_mark_node)
1046 || (size == error_mark_node))
1047 return error_mark_node;
1048
1049 if (size == NULL_TREE) /* Already filled in for CHARACTER type. */
1050 { /* "(ftnlen) sizeof(type)" */
1051 size = size_binop (CEIL_DIV_EXPR,
1052 TYPE_SIZE (ffecom_tree_type[bt][kt]),
1053 size_int (TYPE_PRECISION (char_type_node)));
1054 #if 0 /* Assume that while it is possible that char * is wider than
1055 ftnlen, no object in Fortran space can get big enough for its
1056 size to be wider than ftnlen. I really hope nobody wastes
1057 time debugging a case where it can! */
1058 assert (TYPE_PRECISION (ffecom_f2c_ftnlen_type_node)
1059 >= TYPE_PRECISION (TREE_TYPE (size)));
1060 #endif
1061 size = convert (ffecom_f2c_ftnlen_type_node, size);
1062 }
1063
1064 if (ffeinfo_rank (ffebld_info (expr)) == 0
1065 || TREE_CODE (TREE_TYPE (TREE_TYPE (variable))) != ARRAY_TYPE)
1066 num_elements = ffecom_integer_one_node;
1067 else
1068 {
1069 num_elements = size_binop (CEIL_DIV_EXPR,
1070 TYPE_SIZE (TREE_TYPE (TREE_TYPE (variable))),
1071 size);
1072 num_elements = size_binop (CEIL_DIV_EXPR,
1073 num_elements,
1074 size_int (TYPE_PRECISION
1075 (char_type_node)));
1076 num_elements = convert (ffecom_f2c_ftnlen_type_node,
1077 num_elements);
1078 }
1079
1080 num_elements
1081 = ffecom_1 (ADDR_EXPR, ffecom_f2c_ptr_to_ftnlen_type_node,
1082 num_elements);
1083
1084 variable = convert (string_type_node, variable);
1085
1086 arglist = build_tree_list (NULL_TREE, type_id);
1087 TREE_CHAIN (arglist) = build_tree_list (NULL_TREE, num_elements);
1088 TREE_CHAIN (TREE_CHAIN (arglist)) = build_tree_list (NULL_TREE, variable);
1089 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (arglist)))
1090 = build_tree_list (NULL_TREE, size);
1091
1092 return ffecom_call_gfrt (FFECOM_gfrtDOLIO, arglist, NULL_TREE);
1093 }
1094
1095 #endif
1096 /* I/O driver for unformatted I/O item (do_uio)
1097
1098 Returns a tree for a CALL_EXPR to the do_uio function, which handles
1099 an unformatted I/O list item, along with the appropriate arguments for
1100 the function. It is up to the caller to set the TREE_SIDE_EFFECTS flag
1101 for the CALL_EXPR, expand (emit) the expression, emit any assignment
1102 of the result to an IOSTAT= variable, and emit any checking of the
1103 result for errors. */
1104
1105 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1106 static tree
1107 ffeste_io_douio_ (ffebld expr)
1108 {
1109 tree num_elements;
1110 tree variable;
1111 tree size;
1112 tree arglist;
1113 ffeinfoBasictype bt;
1114 ffeinfoKindtype kt;
1115 bool is_complex;
1116
1117 bt = ffeinfo_basictype (ffebld_info (expr));
1118 kt = ffeinfo_kindtype (ffebld_info (expr));
1119
1120 if ((bt == FFEINFO_basictypeANY)
1121 || (kt == FFEINFO_kindtypeANY))
1122 return error_mark_node;
1123
1124 if (bt == FFEINFO_basictypeCOMPLEX)
1125 {
1126 is_complex = TRUE;
1127 bt = FFEINFO_basictypeREAL;
1128 }
1129 else
1130 is_complex = FALSE;
1131
1132 variable = ffecom_arg_ptr_to_expr (expr, &size);
1133
1134 if ((variable == error_mark_node)
1135 || (size == error_mark_node))
1136 return error_mark_node;
1137
1138 if (size == NULL_TREE) /* Already filled in for CHARACTER type. */
1139 { /* "(ftnlen) sizeof(type)" */
1140 size = size_binop (CEIL_DIV_EXPR,
1141 TYPE_SIZE (ffecom_tree_type[bt][kt]),
1142 size_int (TYPE_PRECISION (char_type_node)));
1143 #if 0 /* Assume that while it is possible that char * is wider than
1144 ftnlen, no object in Fortran space can get big enough for its
1145 size to be wider than ftnlen. I really hope nobody wastes
1146 time debugging a case where it can! */
1147 assert (TYPE_PRECISION (ffecom_f2c_ftnlen_type_node)
1148 >= TYPE_PRECISION (TREE_TYPE (size)));
1149 #endif
1150 size = convert (ffecom_f2c_ftnlen_type_node, size);
1151 }
1152
1153 if (ffeinfo_rank (ffebld_info (expr)) == 0
1154 || TREE_CODE (TREE_TYPE (TREE_TYPE (variable))) != ARRAY_TYPE)
1155 num_elements
1156 = is_complex ? ffecom_f2c_ftnlen_two_node : ffecom_f2c_ftnlen_one_node;
1157 else
1158 {
1159 num_elements = size_binop (CEIL_DIV_EXPR,
1160 TYPE_SIZE (TREE_TYPE (TREE_TYPE (variable))),
1161 size);
1162 num_elements = size_binop (CEIL_DIV_EXPR, num_elements,
1163 size_int (TYPE_PRECISION
1164 (char_type_node)));
1165 num_elements = convert (ffecom_f2c_ftnlen_type_node,
1166 num_elements);
1167 }
1168
1169 num_elements
1170 = ffecom_1 (ADDR_EXPR, ffecom_f2c_ptr_to_ftnlen_type_node,
1171 num_elements);
1172
1173 variable = convert (string_type_node, variable);
1174
1175 arglist = build_tree_list (NULL_TREE, num_elements);
1176 TREE_CHAIN (arglist) = build_tree_list (NULL_TREE, variable);
1177 TREE_CHAIN (TREE_CHAIN (arglist)) = build_tree_list (NULL_TREE, size);
1178
1179 return ffecom_call_gfrt (FFECOM_gfrtDOUIO, arglist, NULL_TREE);
1180 }
1181
1182 #endif
1183 /* Make arglist with ptr to BACKSPACE/ENDFILE/REWIND control list.
1184
1185 Returns a tree suitable as an argument list containing a pointer to
1186 a BACKSPACE/ENDFILE/REWIND control list. First, generates that control
1187 list, if necessary, along with any static and run-time initializations
1188 that are needed as specified by the arguments to this function.
1189
1190 Must ensure that all expressions are prepared before being evaluated,
1191 for any whose evaluation might result in the generation of temporaries.
1192
1193 Note that this means this function causes a transition, within the
1194 current block being code-generated via the back end, from the
1195 declaration of variables (temporaries) to the expanding of expressions,
1196 statements, etc. */
1197
1198 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1199 static tree
1200 ffeste_io_ialist_ (bool have_err,
1201 ffestvUnit unit,
1202 ffebld unit_expr,
1203 int unit_dflt)
1204 {
1205 static tree f2c_alist_struct = NULL_TREE;
1206 tree t;
1207 tree ttype;
1208 int yes;
1209 tree field;
1210 tree inits, initn;
1211 bool constantp = TRUE;
1212 static tree errfield, unitfield;
1213 tree errinit, unitinit;
1214 tree unitexp;
1215 static int mynumber = 0;
1216
1217 if (f2c_alist_struct == NULL_TREE)
1218 {
1219 tree ref;
1220
1221 push_obstacks_nochange ();
1222 end_temporary_allocation ();
1223
1224 ref = make_node (RECORD_TYPE);
1225
1226 errfield = ffecom_decl_field (ref, NULL_TREE, "err",
1227 ffecom_f2c_flag_type_node);
1228 unitfield = ffecom_decl_field (ref, errfield, "unit",
1229 ffecom_f2c_ftnint_type_node);
1230
1231 TYPE_FIELDS (ref) = errfield;
1232 layout_type (ref);
1233
1234 resume_temporary_allocation ();
1235 pop_obstacks ();
1236
1237 f2c_alist_struct = ref;
1238 }
1239
1240 /* Try to do as much compile-time initialization of the structure
1241 as possible, to save run time. */
1242
1243 ffeste_f2c_init_flag_ (have_err, errinit);
1244
1245 switch (unit)
1246 {
1247 case FFESTV_unitNONE:
1248 case FFESTV_unitASTERISK:
1249 unitinit = build_int_2 (unit_dflt, 0);
1250 unitexp = unitinit;
1251 break;
1252
1253 case FFESTV_unitINTEXPR:
1254 unitexp = ffecom_const_expr (unit_expr);
1255 if (unitexp)
1256 unitinit = unitexp;
1257 else
1258 {
1259 unitinit = ffecom_integer_zero_node;
1260 constantp = FALSE;
1261 }
1262 break;
1263
1264 default:
1265 assert ("bad unit spec" == NULL);
1266 unitinit = ffecom_integer_zero_node;
1267 unitexp = unitinit;
1268 break;
1269 }
1270
1271 inits = build_tree_list ((field = TYPE_FIELDS (f2c_alist_struct)), errinit);
1272 initn = inits;
1273 ffeste_f2c_init_next_ (unitinit);
1274
1275 inits = build (CONSTRUCTOR, f2c_alist_struct, NULL_TREE, inits);
1276 TREE_CONSTANT (inits) = constantp ? 1 : 0;
1277 TREE_STATIC (inits) = 1;
1278
1279 yes = suspend_momentary ();
1280
1281 t = build_decl (VAR_DECL,
1282 ffecom_get_invented_identifier ("__g77_alist_%d", NULL,
1283 mynumber++),
1284 f2c_alist_struct);
1285 TREE_STATIC (t) = 1;
1286 t = ffecom_start_decl (t, 1);
1287 ffecom_finish_decl (t, inits, 0);
1288
1289 resume_momentary (yes);
1290
1291 /* Prepare run-time expressions. */
1292
1293 if (! unitexp)
1294 ffecom_prepare_expr (unit_expr);
1295
1296 ffecom_prepare_end ();
1297
1298 /* Now evaluate run-time expressions as needed. */
1299
1300 if (! unitexp)
1301 {
1302 unitexp = ffecom_expr (unit_expr);
1303 ffeste_f2c_compile_ (unitfield, unitexp);
1304 }
1305
1306 ttype = build_pointer_type (TREE_TYPE (t));
1307 t = ffecom_1 (ADDR_EXPR, ttype, t);
1308
1309 t = build_tree_list (NULL_TREE, t);
1310
1311 return t;
1312 }
1313
1314 #endif
1315 /* Make arglist with ptr to external-I/O control list.
1316
1317 Returns a tree suitable as an argument list containing a pointer to
1318 an external-I/O control list. First, generates that control
1319 list, if necessary, along with any static and run-time initializations
1320 that are needed as specified by the arguments to this function.
1321
1322 Must ensure that all expressions are prepared before being evaluated,
1323 for any whose evaluation might result in the generation of temporaries.
1324
1325 Note that this means this function causes a transition, within the
1326 current block being code-generated via the back end, from the
1327 declaration of variables (temporaries) to the expanding of expressions,
1328 statements, etc. */
1329
1330 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1331 static tree
1332 ffeste_io_cilist_ (bool have_err,
1333 ffestvUnit unit,
1334 ffebld unit_expr,
1335 int unit_dflt,
1336 bool have_end,
1337 ffestvFormat format,
1338 ffestpFile *format_spec,
1339 bool rec,
1340 ffebld rec_expr)
1341 {
1342 static tree f2c_cilist_struct = NULL_TREE;
1343 tree t;
1344 tree ttype;
1345 int yes;
1346 tree field;
1347 tree inits, initn;
1348 bool constantp = TRUE;
1349 static tree errfield, unitfield, endfield, formatfield, recfield;
1350 tree errinit, unitinit, endinit, formatinit, recinit;
1351 tree unitexp, formatexp, recexp;
1352 static int mynumber = 0;
1353
1354 if (f2c_cilist_struct == NULL_TREE)
1355 {
1356 tree ref;
1357
1358 push_obstacks_nochange ();
1359 end_temporary_allocation ();
1360
1361 ref = make_node (RECORD_TYPE);
1362
1363 errfield = ffecom_decl_field (ref, NULL_TREE, "err",
1364 ffecom_f2c_flag_type_node);
1365 unitfield = ffecom_decl_field (ref, errfield, "unit",
1366 ffecom_f2c_ftnint_type_node);
1367 endfield = ffecom_decl_field (ref, unitfield, "end",
1368 ffecom_f2c_flag_type_node);
1369 formatfield = ffecom_decl_field (ref, endfield, "format",
1370 string_type_node);
1371 recfield = ffecom_decl_field (ref, formatfield, "rec",
1372 ffecom_f2c_ftnint_type_node);
1373
1374 TYPE_FIELDS (ref) = errfield;
1375 layout_type (ref);
1376
1377 resume_temporary_allocation ();
1378 pop_obstacks ();
1379
1380 f2c_cilist_struct = ref;
1381 }
1382
1383 /* Try to do as much compile-time initialization of the structure
1384 as possible, to save run time. */
1385
1386 ffeste_f2c_init_flag_ (have_err, errinit);
1387
1388 switch (unit)
1389 {
1390 case FFESTV_unitNONE:
1391 case FFESTV_unitASTERISK:
1392 unitinit = build_int_2 (unit_dflt, 0);
1393 unitexp = unitinit;
1394 break;
1395
1396 case FFESTV_unitINTEXPR:
1397 unitexp = ffecom_const_expr (unit_expr);
1398 if (unitexp)
1399 unitinit = unitexp;
1400 else
1401 {
1402 unitinit = ffecom_integer_zero_node;
1403 constantp = FALSE;
1404 }
1405 break;
1406
1407 default:
1408 assert ("bad unit spec" == NULL);
1409 unitinit = ffecom_integer_zero_node;
1410 unitexp = unitinit;
1411 break;
1412 }
1413
1414 switch (format)
1415 {
1416 case FFESTV_formatNONE:
1417 formatinit = null_pointer_node;
1418 formatexp = formatinit;
1419 break;
1420
1421 case FFESTV_formatLABEL:
1422 formatexp = error_mark_node;
1423 formatinit = ffecom_lookup_label (format_spec->u.label);
1424 if ((formatinit == NULL_TREE)
1425 || (TREE_CODE (formatinit) == ERROR_MARK))
1426 break;
1427 formatinit = ffecom_1 (ADDR_EXPR,
1428 build_pointer_type (void_type_node),
1429 formatinit);
1430 TREE_CONSTANT (formatinit) = 1;
1431 break;
1432
1433 case FFESTV_formatCHAREXPR:
1434 formatexp = ffecom_arg_ptr_to_const_expr (format_spec->u.expr, NULL);
1435 if (formatexp)
1436 formatinit = formatexp;
1437 else
1438 {
1439 formatinit = null_pointer_node;
1440 constantp = FALSE;
1441 }
1442 break;
1443
1444 case FFESTV_formatASTERISK:
1445 formatinit = null_pointer_node;
1446 formatexp = formatinit;
1447 break;
1448
1449 case FFESTV_formatINTEXPR:
1450 formatinit = null_pointer_node;
1451 formatexp = ffecom_expr_assign (format_spec->u.expr);
1452 if (GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (formatexp)))
1453 < GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node))))
1454 error ("ASSIGNed FORMAT specifier is too small");
1455 formatexp = convert (string_type_node, formatexp);
1456 break;
1457
1458 case FFESTV_formatNAMELIST:
1459 formatinit = ffecom_expr (format_spec->u.expr);
1460 formatexp = formatinit;
1461 break;
1462
1463 default:
1464 assert ("bad format spec" == NULL);
1465 formatinit = integer_zero_node;
1466 formatexp = formatinit;
1467 break;
1468 }
1469
1470 ffeste_f2c_init_flag_ (have_end, endinit);
1471
1472 if (rec)
1473 recexp = ffecom_const_expr (rec_expr);
1474 else
1475 recexp = ffecom_integer_zero_node;
1476 if (recexp)
1477 recinit = recexp;
1478 else
1479 {
1480 recinit = ffecom_integer_zero_node;
1481 constantp = FALSE;
1482 }
1483
1484 inits = build_tree_list ((field = TYPE_FIELDS (f2c_cilist_struct)), errinit);
1485 initn = inits;
1486 ffeste_f2c_init_next_ (unitinit);
1487 ffeste_f2c_init_next_ (endinit);
1488 ffeste_f2c_init_next_ (formatinit);
1489 ffeste_f2c_init_next_ (recinit);
1490
1491 inits = build (CONSTRUCTOR, f2c_cilist_struct, NULL_TREE, inits);
1492 TREE_CONSTANT (inits) = constantp ? 1 : 0;
1493 TREE_STATIC (inits) = 1;
1494
1495 yes = suspend_momentary ();
1496
1497 t = build_decl (VAR_DECL,
1498 ffecom_get_invented_identifier ("__g77_cilist_%d", NULL,
1499 mynumber++),
1500 f2c_cilist_struct);
1501 TREE_STATIC (t) = 1;
1502 t = ffecom_start_decl (t, 1);
1503 ffecom_finish_decl (t, inits, 0);
1504
1505 resume_momentary (yes);
1506
1507 /* Prepare run-time expressions. */
1508
1509 if (! unitexp)
1510 ffecom_prepare_expr (unit_expr);
1511
1512 if (! formatexp)
1513 ffecom_prepare_arg_ptr_to_expr (format_spec->u.expr);
1514
1515 if (! recexp)
1516 ffecom_prepare_expr (rec_expr);
1517
1518 ffecom_prepare_end ();
1519
1520 /* Now evaluate run-time expressions as needed. */
1521
1522 if (! unitexp)
1523 {
1524 unitexp = ffecom_expr (unit_expr);
1525 ffeste_f2c_compile_ (unitfield, unitexp);
1526 }
1527
1528 if (! formatexp)
1529 {
1530 formatexp = ffecom_arg_ptr_to_expr (format_spec->u.expr, NULL);
1531 ffeste_f2c_compile_ (formatfield, formatexp);
1532 }
1533 else if (format == FFESTV_formatINTEXPR)
1534 ffeste_f2c_compile_ (formatfield, formatexp);
1535
1536 if (! recexp)
1537 {
1538 recexp = ffecom_expr (rec_expr);
1539 ffeste_f2c_compile_ (recfield, recexp);
1540 }
1541
1542 ttype = build_pointer_type (TREE_TYPE (t));
1543 t = ffecom_1 (ADDR_EXPR, ttype, t);
1544
1545 t = build_tree_list (NULL_TREE, t);
1546
1547 return t;
1548 }
1549
1550 #endif
1551 /* Make arglist with ptr to CLOSE control list.
1552
1553 Returns a tree suitable as an argument list containing a pointer to
1554 a CLOSE-statement control list. First, generates that control
1555 list, if necessary, along with any static and run-time initializations
1556 that are needed as specified by the arguments to this function.
1557
1558 Must ensure that all expressions are prepared before being evaluated,
1559 for any whose evaluation might result in the generation of temporaries.
1560
1561 Note that this means this function causes a transition, within the
1562 current block being code-generated via the back end, from the
1563 declaration of variables (temporaries) to the expanding of expressions,
1564 statements, etc. */
1565
1566 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1567 static tree
1568 ffeste_io_cllist_ (bool have_err,
1569 ffebld unit_expr,
1570 ffestpFile *stat_spec)
1571 {
1572 static tree f2c_close_struct = NULL_TREE;
1573 tree t;
1574 tree ttype;
1575 int yes;
1576 tree field;
1577 tree inits, initn;
1578 tree ignore; /* Ignore length info for certain fields. */
1579 bool constantp = TRUE;
1580 static tree errfield, unitfield, statfield;
1581 tree errinit, unitinit, statinit;
1582 tree unitexp, statexp;
1583 static int mynumber = 0;
1584
1585 if (f2c_close_struct == NULL_TREE)
1586 {
1587 tree ref;
1588
1589 push_obstacks_nochange ();
1590 end_temporary_allocation ();
1591
1592 ref = make_node (RECORD_TYPE);
1593
1594 errfield = ffecom_decl_field (ref, NULL_TREE, "err",
1595 ffecom_f2c_flag_type_node);
1596 unitfield = ffecom_decl_field (ref, errfield, "unit",
1597 ffecom_f2c_ftnint_type_node);
1598 statfield = ffecom_decl_field (ref, unitfield, "stat",
1599 string_type_node);
1600
1601 TYPE_FIELDS (ref) = errfield;
1602 layout_type (ref);
1603
1604 resume_temporary_allocation ();
1605 pop_obstacks ();
1606
1607 f2c_close_struct = ref;
1608 }
1609
1610 /* Try to do as much compile-time initialization of the structure
1611 as possible, to save run time. */
1612
1613 ffeste_f2c_init_flag_ (have_err, errinit);
1614
1615 unitexp = ffecom_const_expr (unit_expr);
1616 if (unitexp)
1617 unitinit = unitexp;
1618 else
1619 {
1620 unitinit = ffecom_integer_zero_node;
1621 constantp = FALSE;
1622 }
1623
1624 ffeste_f2c_init_charnolen_ (statexp, statinit, stat_spec);
1625
1626 inits = build_tree_list ((field = TYPE_FIELDS (f2c_close_struct)), errinit);
1627 initn = inits;
1628 ffeste_f2c_init_next_ (unitinit);
1629 ffeste_f2c_init_next_ (statinit);
1630
1631 inits = build (CONSTRUCTOR, f2c_close_struct, NULL_TREE, inits);
1632 TREE_CONSTANT (inits) = constantp ? 1 : 0;
1633 TREE_STATIC (inits) = 1;
1634
1635 yes = suspend_momentary ();
1636
1637 t = build_decl (VAR_DECL,
1638 ffecom_get_invented_identifier ("__g77_cllist_%d", NULL,
1639 mynumber++),
1640 f2c_close_struct);
1641 TREE_STATIC (t) = 1;
1642 t = ffecom_start_decl (t, 1);
1643 ffecom_finish_decl (t, inits, 0);
1644
1645 resume_momentary (yes);
1646
1647 /* Prepare run-time expressions. */
1648
1649 if (! unitexp)
1650 ffecom_prepare_expr (unit_expr);
1651
1652 if (! statexp)
1653 ffecom_prepare_arg_ptr_to_expr (stat_spec->u.expr);
1654
1655 ffecom_prepare_end ();
1656
1657 /* Now evaluate run-time expressions as needed. */
1658
1659 if (! unitexp)
1660 {
1661 unitexp = ffecom_expr (unit_expr);
1662 ffeste_f2c_compile_ (unitfield, unitexp);
1663 }
1664
1665 ffeste_f2c_compile_charnolen_ (statfield, stat_spec, statexp);
1666
1667 ttype = build_pointer_type (TREE_TYPE (t));
1668 t = ffecom_1 (ADDR_EXPR, ttype, t);
1669
1670 t = build_tree_list (NULL_TREE, t);
1671
1672 return t;
1673 }
1674
1675 #endif
1676 /* Make arglist with ptr to internal-I/O control list.
1677
1678 Returns a tree suitable as an argument list containing a pointer to
1679 an internal-I/O control list. First, generates that control
1680 list, if necessary, along with any static and run-time initializations
1681 that are needed as specified by the arguments to this function.
1682
1683 Must ensure that all expressions are prepared before being evaluated,
1684 for any whose evaluation might result in the generation of temporaries.
1685
1686 Note that this means this function causes a transition, within the
1687 current block being code-generated via the back end, from the
1688 declaration of variables (temporaries) to the expanding of expressions,
1689 statements, etc. */
1690
1691 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1692 static tree
1693 ffeste_io_icilist_ (bool have_err,
1694 ffebld unit_expr,
1695 bool have_end,
1696 ffestvFormat format,
1697 ffestpFile *format_spec)
1698 {
1699 static tree f2c_icilist_struct = NULL_TREE;
1700 tree t;
1701 tree ttype;
1702 int yes;
1703 tree field;
1704 tree inits, initn;
1705 bool constantp = TRUE;
1706 static tree errfield, unitfield, endfield, formatfield, unitlenfield,
1707 unitnumfield;
1708 tree errinit, unitinit, endinit, formatinit, unitleninit, unitnuminit;
1709 tree unitexp, formatexp, unitlenexp, unitnumexp;
1710 static int mynumber = 0;
1711
1712 if (f2c_icilist_struct == NULL_TREE)
1713 {
1714 tree ref;
1715
1716 push_obstacks_nochange ();
1717 end_temporary_allocation ();
1718
1719 ref = make_node (RECORD_TYPE);
1720
1721 errfield = ffecom_decl_field (ref, NULL_TREE, "err",
1722 ffecom_f2c_flag_type_node);
1723 unitfield = ffecom_decl_field (ref, errfield, "unit",
1724 string_type_node);
1725 endfield = ffecom_decl_field (ref, unitfield, "end",
1726 ffecom_f2c_flag_type_node);
1727 formatfield = ffecom_decl_field (ref, endfield, "format",
1728 string_type_node);
1729 unitlenfield = ffecom_decl_field (ref, formatfield, "unitlen",
1730 ffecom_f2c_ftnint_type_node);
1731 unitnumfield = ffecom_decl_field (ref, unitlenfield, "unitnum",
1732 ffecom_f2c_ftnint_type_node);
1733
1734 TYPE_FIELDS (ref) = errfield;
1735 layout_type (ref);
1736
1737 resume_temporary_allocation ();
1738 pop_obstacks ();
1739
1740 f2c_icilist_struct = ref;
1741 }
1742
1743 /* Try to do as much compile-time initialization of the structure
1744 as possible, to save run time. */
1745
1746 ffeste_f2c_init_flag_ (have_err, errinit);
1747
1748 unitexp = ffecom_arg_ptr_to_const_expr (unit_expr, &unitlenexp);
1749 if (unitexp)
1750 unitinit = unitexp;
1751 else
1752 {
1753 unitinit = null_pointer_node;
1754 constantp = FALSE;
1755 }
1756 if (unitlenexp)
1757 unitleninit = unitlenexp;
1758 else
1759 {
1760 unitleninit = ffecom_integer_zero_node;
1761 constantp = FALSE;
1762 }
1763
1764 /* Now see if we can fully initialize the number of elements, or
1765 if we have to compute that at run time. */
1766 if (ffeinfo_rank (ffebld_info (unit_expr)) == 0
1767 || (unitexp
1768 && TREE_CODE (TREE_TYPE (TREE_TYPE (unitexp))) != ARRAY_TYPE))
1769 {
1770 /* Not an array, so just one element. */
1771 unitnuminit = ffecom_integer_one_node;
1772 unitnumexp = unitnuminit;
1773 }
1774 else if (unitexp && unitlenexp)
1775 {
1776 /* An array, but all the info is constant, so compute now. */
1777 unitnuminit = size_binop (CEIL_DIV_EXPR,
1778 TYPE_SIZE (TREE_TYPE (TREE_TYPE (unitexp))),
1779 unitlenexp);
1780 unitnuminit = size_binop (CEIL_DIV_EXPR,
1781 unitnuminit,
1782 size_int (TYPE_PRECISION
1783 (char_type_node)));
1784 unitnumexp = unitnuminit;
1785 }
1786 else
1787 {
1788 /* Put off computing until run time. */
1789 unitnuminit = ffecom_integer_zero_node;
1790 unitnumexp = NULL_TREE;
1791 constantp = FALSE;
1792 }
1793
1794 switch (format)
1795 {
1796 case FFESTV_formatNONE:
1797 formatinit = null_pointer_node;
1798 formatexp = formatinit;
1799 break;
1800
1801 case FFESTV_formatLABEL:
1802 formatexp = error_mark_node;
1803 formatinit = ffecom_lookup_label (format_spec->u.label);
1804 if ((formatinit == NULL_TREE)
1805 || (TREE_CODE (formatinit) == ERROR_MARK))
1806 break;
1807 formatinit = ffecom_1 (ADDR_EXPR,
1808 build_pointer_type (void_type_node),
1809 formatinit);
1810 TREE_CONSTANT (formatinit) = 1;
1811 break;
1812
1813 case FFESTV_formatCHAREXPR:
1814 ffeste_f2c_init_format_ (formatexp, formatinit, format_spec);
1815 break;
1816
1817 case FFESTV_formatASTERISK:
1818 formatinit = null_pointer_node;
1819 formatexp = formatinit;
1820 break;
1821
1822 case FFESTV_formatINTEXPR:
1823 formatinit = null_pointer_node;
1824 formatexp = ffecom_expr_assign (format_spec->u.expr);
1825 if (GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (formatexp)))
1826 < GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node))))
1827 error ("ASSIGNed FORMAT specifier is too small");
1828 formatexp = convert (string_type_node, formatexp);
1829 break;
1830
1831 default:
1832 assert ("bad format spec" == NULL);
1833 formatinit = ffecom_integer_zero_node;
1834 formatexp = formatinit;
1835 break;
1836 }
1837
1838 ffeste_f2c_init_flag_ (have_end, endinit);
1839
1840 inits = build_tree_list ((field = TYPE_FIELDS (f2c_icilist_struct)),
1841 errinit);
1842 initn = inits;
1843 ffeste_f2c_init_next_ (unitinit);
1844 ffeste_f2c_init_next_ (endinit);
1845 ffeste_f2c_init_next_ (formatinit);
1846 ffeste_f2c_init_next_ (unitleninit);
1847 ffeste_f2c_init_next_ (unitnuminit);
1848
1849 inits = build (CONSTRUCTOR, f2c_icilist_struct, NULL_TREE, inits);
1850 TREE_CONSTANT (inits) = constantp ? 1 : 0;
1851 TREE_STATIC (inits) = 1;
1852
1853 yes = suspend_momentary ();
1854
1855 t = build_decl (VAR_DECL,
1856 ffecom_get_invented_identifier ("__g77_icilist_%d", NULL,
1857 mynumber++),
1858 f2c_icilist_struct);
1859 TREE_STATIC (t) = 1;
1860 t = ffecom_start_decl (t, 1);
1861 ffecom_finish_decl (t, inits, 0);
1862
1863 resume_momentary (yes);
1864
1865 /* Prepare run-time expressions. */
1866
1867 if (! unitexp)
1868 ffecom_prepare_arg_ptr_to_expr (unit_expr);
1869
1870 ffeste_f2c_prepare_format_ (format_spec, formatexp);
1871
1872 ffecom_prepare_end ();
1873
1874 /* Now evaluate run-time expressions as needed. */
1875
1876 if (! unitexp || ! unitlenexp)
1877 {
1878 int need_unitexp = (! unitexp);
1879 int need_unitlenexp = (! unitlenexp);
1880
1881 unitexp = ffecom_arg_ptr_to_expr (unit_expr, &unitlenexp);
1882 if (need_unitexp)
1883 ffeste_f2c_compile_ (unitfield, unitexp);
1884 if (need_unitlenexp)
1885 ffeste_f2c_compile_ (unitlenfield, unitlenexp);
1886 }
1887
1888 if (! unitnumexp
1889 && unitexp != error_mark_node
1890 && unitlenexp != error_mark_node)
1891 {
1892 unitnumexp = size_binop (CEIL_DIV_EXPR,
1893 TYPE_SIZE (TREE_TYPE (TREE_TYPE (unitexp))),
1894 unitlenexp);
1895 unitnumexp = size_binop (CEIL_DIV_EXPR,
1896 unitnumexp,
1897 size_int (TYPE_PRECISION
1898 (char_type_node)));
1899 ffeste_f2c_compile_ (unitnumfield, unitnumexp);
1900 }
1901
1902 if (format == FFESTV_formatINTEXPR)
1903 ffeste_f2c_compile_ (formatfield, formatexp);
1904 else
1905 ffeste_f2c_compile_format_ (formatfield, format_spec, formatexp);
1906
1907 ttype = build_pointer_type (TREE_TYPE (t));
1908 t = ffecom_1 (ADDR_EXPR, ttype, t);
1909
1910 t = build_tree_list (NULL_TREE, t);
1911
1912 return t;
1913 }
1914 #endif
1915
1916 /* Make arglist with ptr to INQUIRE control list
1917
1918 Returns a tree suitable as an argument list containing a pointer to
1919 an INQUIRE-statement control list. First, generates that control
1920 list, if necessary, along with any static and run-time initializations
1921 that are needed as specified by the arguments to this function.
1922
1923 Must ensure that all expressions are prepared before being evaluated,
1924 for any whose evaluation might result in the generation of temporaries.
1925
1926 Note that this means this function causes a transition, within the
1927 current block being code-generated via the back end, from the
1928 declaration of variables (temporaries) to the expanding of expressions,
1929 statements, etc. */
1930
1931 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1932 static tree
1933 ffeste_io_inlist_ (bool have_err,
1934 ffestpFile *unit_spec,
1935 ffestpFile *file_spec,
1936 ffestpFile *exist_spec,
1937 ffestpFile *open_spec,
1938 ffestpFile *number_spec,
1939 ffestpFile *named_spec,
1940 ffestpFile *name_spec,
1941 ffestpFile *access_spec,
1942 ffestpFile *sequential_spec,
1943 ffestpFile *direct_spec,
1944 ffestpFile *form_spec,
1945 ffestpFile *formatted_spec,
1946 ffestpFile *unformatted_spec,
1947 ffestpFile *recl_spec,
1948 ffestpFile *nextrec_spec,
1949 ffestpFile *blank_spec)
1950 {
1951 static tree f2c_inquire_struct = NULL_TREE;
1952 tree t;
1953 tree ttype;
1954 int yes;
1955 tree field;
1956 tree inits, initn;
1957 bool constantp = TRUE;
1958 static tree errfield, unitfield, filefield, filelenfield, existfield,
1959 openfield, numberfield, namedfield, namefield, namelenfield, accessfield,
1960 accesslenfield, sequentialfield, sequentiallenfield, directfield, directlenfield,
1961 formfield, formlenfield, formattedfield, formattedlenfield, unformattedfield,
1962 unformattedlenfield, reclfield, nextrecfield, blankfield, blanklenfield;
1963 tree errinit, unitinit, fileinit, fileleninit, existinit, openinit, numberinit,
1964 namedinit, nameinit, nameleninit, accessinit, accessleninit, sequentialinit,
1965 sequentialleninit, directinit, directleninit, forminit, formleninit,
1966 formattedinit, formattedleninit, unformattedinit, unformattedleninit,
1967 reclinit, nextrecinit, blankinit, blankleninit;
1968 tree
1969 unitexp, fileexp, filelenexp, existexp, openexp, numberexp, namedexp,
1970 nameexp, namelenexp, accessexp, accesslenexp, sequentialexp, sequentiallenexp,
1971 directexp, directlenexp, formexp, formlenexp, formattedexp, formattedlenexp,
1972 unformattedexp, unformattedlenexp, reclexp, nextrecexp, blankexp, blanklenexp;
1973 static int mynumber = 0;
1974
1975 if (f2c_inquire_struct == NULL_TREE)
1976 {
1977 tree ref;
1978
1979 push_obstacks_nochange ();
1980 end_temporary_allocation ();
1981
1982 ref = make_node (RECORD_TYPE);
1983
1984 errfield = ffecom_decl_field (ref, NULL_TREE, "err",
1985 ffecom_f2c_flag_type_node);
1986 unitfield = ffecom_decl_field (ref, errfield, "unit",
1987 ffecom_f2c_ftnint_type_node);
1988 filefield = ffecom_decl_field (ref, unitfield, "file",
1989 string_type_node);
1990 filelenfield = ffecom_decl_field (ref, filefield, "filelen",
1991 ffecom_f2c_ftnlen_type_node);
1992 existfield = ffecom_decl_field (ref, filelenfield, "exist",
1993 ffecom_f2c_ptr_to_ftnint_type_node);
1994 openfield = ffecom_decl_field (ref, existfield, "open",
1995 ffecom_f2c_ptr_to_ftnint_type_node);
1996 numberfield = ffecom_decl_field (ref, openfield, "number",
1997 ffecom_f2c_ptr_to_ftnint_type_node);
1998 namedfield = ffecom_decl_field (ref, numberfield, "named",
1999 ffecom_f2c_ptr_to_ftnint_type_node);
2000 namefield = ffecom_decl_field (ref, namedfield, "name",
2001 string_type_node);
2002 namelenfield = ffecom_decl_field (ref, namefield, "namelen",
2003 ffecom_f2c_ftnlen_type_node);
2004 accessfield = ffecom_decl_field (ref, namelenfield, "access",
2005 string_type_node);
2006 accesslenfield = ffecom_decl_field (ref, accessfield, "accesslen",
2007 ffecom_f2c_ftnlen_type_node);
2008 sequentialfield = ffecom_decl_field (ref, accesslenfield, "sequential",
2009 string_type_node);
2010 sequentiallenfield = ffecom_decl_field (ref, sequentialfield,
2011 "sequentiallen",
2012 ffecom_f2c_ftnlen_type_node);
2013 directfield = ffecom_decl_field (ref, sequentiallenfield, "direct",
2014 string_type_node);
2015 directlenfield = ffecom_decl_field (ref, directfield, "directlen",
2016 ffecom_f2c_ftnlen_type_node);
2017 formfield = ffecom_decl_field (ref, directlenfield, "form",
2018 string_type_node);
2019 formlenfield = ffecom_decl_field (ref, formfield, "formlen",
2020 ffecom_f2c_ftnlen_type_node);
2021 formattedfield = ffecom_decl_field (ref, formlenfield, "formatted",
2022 string_type_node);
2023 formattedlenfield = ffecom_decl_field (ref, formattedfield,
2024 "formattedlen",
2025 ffecom_f2c_ftnlen_type_node);
2026 unformattedfield = ffecom_decl_field (ref, formattedlenfield,
2027 "unformatted",
2028 string_type_node);
2029 unformattedlenfield = ffecom_decl_field (ref, unformattedfield,
2030 "unformattedlen",
2031 ffecom_f2c_ftnlen_type_node);
2032 reclfield = ffecom_decl_field (ref, unformattedlenfield, "recl",
2033 ffecom_f2c_ptr_to_ftnint_type_node);
2034 nextrecfield = ffecom_decl_field (ref, reclfield, "nextrec",
2035 ffecom_f2c_ptr_to_ftnint_type_node);
2036 blankfield = ffecom_decl_field (ref, nextrecfield, "blank",
2037 string_type_node);
2038 blanklenfield = ffecom_decl_field (ref, blankfield, "blanklen",
2039 ffecom_f2c_ftnlen_type_node);
2040
2041 TYPE_FIELDS (ref) = errfield;
2042 layout_type (ref);
2043
2044 resume_temporary_allocation ();
2045 pop_obstacks ();
2046
2047 f2c_inquire_struct = ref;
2048 }
2049
2050 /* Try to do as much compile-time initialization of the structure
2051 as possible, to save run time. */
2052
2053 ffeste_f2c_init_flag_ (have_err, errinit);
2054 ffeste_f2c_init_int_ (unitexp, unitinit, unit_spec);
2055 ffeste_f2c_init_char_ (fileexp, fileinit, filelenexp, fileleninit,
2056 file_spec);
2057 ffeste_f2c_init_ptrtoint_ (existexp, existinit, exist_spec);
2058 ffeste_f2c_init_ptrtoint_ (openexp, openinit, open_spec);
2059 ffeste_f2c_init_ptrtoint_ (numberexp, numberinit, number_spec);
2060 ffeste_f2c_init_ptrtoint_ (namedexp, namedinit, named_spec);
2061 ffeste_f2c_init_char_ (nameexp, nameinit, namelenexp, nameleninit,
2062 name_spec);
2063 ffeste_f2c_init_char_ (accessexp, accessinit, accesslenexp,
2064 accessleninit, access_spec);
2065 ffeste_f2c_init_char_ (sequentialexp, sequentialinit, sequentiallenexp,
2066 sequentialleninit, sequential_spec);
2067 ffeste_f2c_init_char_ (directexp, directinit, directlenexp,
2068 directleninit, direct_spec);
2069 ffeste_f2c_init_char_ (formexp, forminit, formlenexp, formleninit,
2070 form_spec);
2071 ffeste_f2c_init_char_ (formattedexp, formattedinit,
2072 formattedlenexp, formattedleninit, formatted_spec);
2073 ffeste_f2c_init_char_ (unformattedexp, unformattedinit, unformattedlenexp,
2074 unformattedleninit, unformatted_spec);
2075 ffeste_f2c_init_ptrtoint_ (reclexp, reclinit, recl_spec);
2076 ffeste_f2c_init_ptrtoint_ (nextrecexp, nextrecinit, nextrec_spec);
2077 ffeste_f2c_init_char_ (blankexp, blankinit, blanklenexp,
2078 blankleninit, blank_spec);
2079
2080 inits = build_tree_list ((field = TYPE_FIELDS (f2c_inquire_struct)),
2081 errinit);
2082 initn = inits;
2083 ffeste_f2c_init_next_ (unitinit);
2084 ffeste_f2c_init_next_ (fileinit);
2085 ffeste_f2c_init_next_ (fileleninit);
2086 ffeste_f2c_init_next_ (existinit);
2087 ffeste_f2c_init_next_ (openinit);
2088 ffeste_f2c_init_next_ (numberinit);
2089 ffeste_f2c_init_next_ (namedinit);
2090 ffeste_f2c_init_next_ (nameinit);
2091 ffeste_f2c_init_next_ (nameleninit);
2092 ffeste_f2c_init_next_ (accessinit);
2093 ffeste_f2c_init_next_ (accessleninit);
2094 ffeste_f2c_init_next_ (sequentialinit);
2095 ffeste_f2c_init_next_ (sequentialleninit);
2096 ffeste_f2c_init_next_ (directinit);
2097 ffeste_f2c_init_next_ (directleninit);
2098 ffeste_f2c_init_next_ (forminit);
2099 ffeste_f2c_init_next_ (formleninit);
2100 ffeste_f2c_init_next_ (formattedinit);
2101 ffeste_f2c_init_next_ (formattedleninit);
2102 ffeste_f2c_init_next_ (unformattedinit);
2103 ffeste_f2c_init_next_ (unformattedleninit);
2104 ffeste_f2c_init_next_ (reclinit);
2105 ffeste_f2c_init_next_ (nextrecinit);
2106 ffeste_f2c_init_next_ (blankinit);
2107 ffeste_f2c_init_next_ (blankleninit);
2108
2109 inits = build (CONSTRUCTOR, f2c_inquire_struct, NULL_TREE, inits);
2110 TREE_CONSTANT (inits) = constantp ? 1 : 0;
2111 TREE_STATIC (inits) = 1;
2112
2113 yes = suspend_momentary ();
2114
2115 t = build_decl (VAR_DECL,
2116 ffecom_get_invented_identifier ("__g77_inlist_%d", NULL,
2117 mynumber++),
2118 f2c_inquire_struct);
2119 TREE_STATIC (t) = 1;
2120 t = ffecom_start_decl (t, 1);
2121 ffecom_finish_decl (t, inits, 0);
2122
2123 resume_momentary (yes);
2124
2125 /* Prepare run-time expressions. */
2126
2127 ffeste_f2c_prepare_int_ (unit_spec, unitexp);
2128 ffeste_f2c_prepare_char_ (file_spec, fileexp);
2129 ffeste_f2c_prepare_ptrtoint_ (exist_spec, existexp);
2130 ffeste_f2c_prepare_ptrtoint_ (open_spec, openexp);
2131 ffeste_f2c_prepare_ptrtoint_ (number_spec, numberexp);
2132 ffeste_f2c_prepare_ptrtoint_ (named_spec, namedexp);
2133 ffeste_f2c_prepare_char_ (name_spec, nameexp);
2134 ffeste_f2c_prepare_char_ (access_spec, accessexp);
2135 ffeste_f2c_prepare_char_ (sequential_spec, sequentialexp);
2136 ffeste_f2c_prepare_char_ (direct_spec, directexp);
2137 ffeste_f2c_prepare_char_ (form_spec, formexp);
2138 ffeste_f2c_prepare_char_ (formatted_spec, formattedexp);
2139 ffeste_f2c_prepare_char_ (unformatted_spec, unformattedexp);
2140 ffeste_f2c_prepare_ptrtoint_ (recl_spec, reclexp);
2141 ffeste_f2c_prepare_ptrtoint_ (nextrec_spec, nextrecexp);
2142 ffeste_f2c_prepare_char_ (blank_spec, blankexp);
2143
2144 ffecom_prepare_end ();
2145
2146 /* Now evaluate run-time expressions as needed. */
2147
2148 ffeste_f2c_compile_int_ (unitfield, unit_spec, unitexp);
2149 ffeste_f2c_compile_char_ (filefield, filelenfield, file_spec,
2150 fileexp, filelenexp);
2151 ffeste_f2c_compile_ptrtoint_ (existfield, exist_spec, existexp);
2152 ffeste_f2c_compile_ptrtoint_ (openfield, open_spec, openexp);
2153 ffeste_f2c_compile_ptrtoint_ (numberfield, number_spec, numberexp);
2154 ffeste_f2c_compile_ptrtoint_ (namedfield, named_spec, namedexp);
2155 ffeste_f2c_compile_char_ (namefield, namelenfield, name_spec, nameexp,
2156 namelenexp);
2157 ffeste_f2c_compile_char_ (accessfield, accesslenfield, access_spec,
2158 accessexp, accesslenexp);
2159 ffeste_f2c_compile_char_ (sequentialfield, sequentiallenfield,
2160 sequential_spec, sequentialexp,
2161 sequentiallenexp);
2162 ffeste_f2c_compile_char_ (directfield, directlenfield, direct_spec,
2163 directexp, directlenexp);
2164 ffeste_f2c_compile_char_ (formfield, formlenfield, form_spec, formexp,
2165 formlenexp);
2166 ffeste_f2c_compile_char_ (formattedfield, formattedlenfield, formatted_spec,
2167 formattedexp, formattedlenexp);
2168 ffeste_f2c_compile_char_ (unformattedfield, unformattedlenfield,
2169 unformatted_spec, unformattedexp,
2170 unformattedlenexp);
2171 ffeste_f2c_compile_ptrtoint_ (reclfield, recl_spec, reclexp);
2172 ffeste_f2c_compile_ptrtoint_ (nextrecfield, nextrec_spec, nextrecexp);
2173 ffeste_f2c_compile_char_ (blankfield, blanklenfield, blank_spec, blankexp,
2174 blanklenexp);
2175
2176 ttype = build_pointer_type (TREE_TYPE (t));
2177 t = ffecom_1 (ADDR_EXPR, ttype, t);
2178
2179 t = build_tree_list (NULL_TREE, t);
2180
2181 return t;
2182 }
2183
2184 #endif
2185 /* Make arglist with ptr to OPEN control list
2186
2187 Returns a tree suitable as an argument list containing a pointer to
2188 an OPEN-statement control list. First, generates that control
2189 list, if necessary, along with any static and run-time initializations
2190 that are needed as specified by the arguments to this function.
2191
2192 Must ensure that all expressions are prepared before being evaluated,
2193 for any whose evaluation might result in the generation of temporaries.
2194
2195 Note that this means this function causes a transition, within the
2196 current block being code-generated via the back end, from the
2197 declaration of variables (temporaries) to the expanding of expressions,
2198 statements, etc. */
2199
2200 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2201 static tree
2202 ffeste_io_olist_ (bool have_err,
2203 ffebld unit_expr,
2204 ffestpFile *file_spec,
2205 ffestpFile *stat_spec,
2206 ffestpFile *access_spec,
2207 ffestpFile *form_spec,
2208 ffestpFile *recl_spec,
2209 ffestpFile *blank_spec)
2210 {
2211 static tree f2c_open_struct = NULL_TREE;
2212 tree t;
2213 tree ttype;
2214 int yes;
2215 tree field;
2216 tree inits, initn;
2217 tree ignore; /* Ignore length info for certain fields. */
2218 bool constantp = TRUE;
2219 static tree errfield, unitfield, filefield, filelenfield, statfield,
2220 accessfield, formfield, reclfield, blankfield;
2221 tree errinit, unitinit, fileinit, fileleninit, statinit, accessinit,
2222 forminit, reclinit, blankinit;
2223 tree
2224 unitexp, fileexp, filelenexp, statexp, accessexp, formexp, reclexp,
2225 blankexp;
2226 static int mynumber = 0;
2227
2228 if (f2c_open_struct == NULL_TREE)
2229 {
2230 tree ref;
2231
2232 push_obstacks_nochange ();
2233 end_temporary_allocation ();
2234
2235 ref = make_node (RECORD_TYPE);
2236
2237 errfield = ffecom_decl_field (ref, NULL_TREE, "err",
2238 ffecom_f2c_flag_type_node);
2239 unitfield = ffecom_decl_field (ref, errfield, "unit",
2240 ffecom_f2c_ftnint_type_node);
2241 filefield = ffecom_decl_field (ref, unitfield, "file",
2242 string_type_node);
2243 filelenfield = ffecom_decl_field (ref, filefield, "filelen",
2244 ffecom_f2c_ftnlen_type_node);
2245 statfield = ffecom_decl_field (ref, filelenfield, "stat",
2246 string_type_node);
2247 accessfield = ffecom_decl_field (ref, statfield, "access",
2248 string_type_node);
2249 formfield = ffecom_decl_field (ref, accessfield, "form",
2250 string_type_node);
2251 reclfield = ffecom_decl_field (ref, formfield, "recl",
2252 ffecom_f2c_ftnint_type_node);
2253 blankfield = ffecom_decl_field (ref, reclfield, "blank",
2254 string_type_node);
2255
2256 TYPE_FIELDS (ref) = errfield;
2257 layout_type (ref);
2258
2259 resume_temporary_allocation ();
2260 pop_obstacks ();
2261
2262 f2c_open_struct = ref;
2263 }
2264
2265 /* Try to do as much compile-time initialization of the structure
2266 as possible, to save run time. */
2267
2268 ffeste_f2c_init_flag_ (have_err, errinit);
2269
2270 unitexp = ffecom_const_expr (unit_expr);
2271 if (unitexp)
2272 unitinit = unitexp;
2273 else
2274 {
2275 unitinit = ffecom_integer_zero_node;
2276 constantp = FALSE;
2277 }
2278
2279 ffeste_f2c_init_char_ (fileexp, fileinit, filelenexp, fileleninit,
2280 file_spec);
2281 ffeste_f2c_init_charnolen_ (statexp, statinit, stat_spec);
2282 ffeste_f2c_init_charnolen_ (accessexp, accessinit, access_spec);
2283 ffeste_f2c_init_charnolen_ (formexp, forminit, form_spec);
2284 ffeste_f2c_init_int_ (reclexp, reclinit, recl_spec);
2285 ffeste_f2c_init_charnolen_ (blankexp, blankinit, blank_spec);
2286
2287 inits = build_tree_list ((field = TYPE_FIELDS (f2c_open_struct)), errinit);
2288 initn = inits;
2289 ffeste_f2c_init_next_ (unitinit);
2290 ffeste_f2c_init_next_ (fileinit);
2291 ffeste_f2c_init_next_ (fileleninit);
2292 ffeste_f2c_init_next_ (statinit);
2293 ffeste_f2c_init_next_ (accessinit);
2294 ffeste_f2c_init_next_ (forminit);
2295 ffeste_f2c_init_next_ (reclinit);
2296 ffeste_f2c_init_next_ (blankinit);
2297
2298 inits = build (CONSTRUCTOR, f2c_open_struct, NULL_TREE, inits);
2299 TREE_CONSTANT (inits) = constantp ? 1 : 0;
2300 TREE_STATIC (inits) = 1;
2301
2302 yes = suspend_momentary ();
2303
2304 t = build_decl (VAR_DECL,
2305 ffecom_get_invented_identifier ("__g77_olist_%d", NULL,
2306 mynumber++),
2307 f2c_open_struct);
2308 TREE_STATIC (t) = 1;
2309 t = ffecom_start_decl (t, 1);
2310 ffecom_finish_decl (t, inits, 0);
2311
2312 resume_momentary (yes);
2313
2314 /* Prepare run-time expressions. */
2315
2316 if (! unitexp)
2317 ffecom_prepare_expr (unit_expr);
2318
2319 ffeste_f2c_prepare_char_ (file_spec, fileexp);
2320 ffeste_f2c_prepare_charnolen_ (stat_spec, statexp);
2321 ffeste_f2c_prepare_charnolen_ (access_spec, accessexp);
2322 ffeste_f2c_prepare_charnolen_ (form_spec, formexp);
2323 ffeste_f2c_prepare_int_ (recl_spec, reclexp);
2324 ffeste_f2c_prepare_charnolen_ (blank_spec, blankexp);
2325
2326 ffecom_prepare_end ();
2327
2328 /* Now evaluate run-time expressions as needed. */
2329
2330 if (! unitexp)
2331 {
2332 unitexp = ffecom_expr (unit_expr);
2333 ffeste_f2c_compile_ (unitfield, unitexp);
2334 }
2335
2336 ffeste_f2c_compile_char_ (filefield, filelenfield, file_spec, fileexp,
2337 filelenexp);
2338 ffeste_f2c_compile_charnolen_ (statfield, stat_spec, statexp);
2339 ffeste_f2c_compile_charnolen_ (accessfield, access_spec, accessexp);
2340 ffeste_f2c_compile_charnolen_ (formfield, form_spec, formexp);
2341 ffeste_f2c_compile_int_ (reclfield, recl_spec, reclexp);
2342 ffeste_f2c_compile_charnolen_ (blankfield, blank_spec, blankexp);
2343
2344 ttype = build_pointer_type (TREE_TYPE (t));
2345 t = ffecom_1 (ADDR_EXPR, ttype, t);
2346
2347 t = build_tree_list (NULL_TREE, t);
2348
2349 return t;
2350 }
2351
2352 #endif
2353 /* Display file-statement specifier. */
2354
2355 #if FFECOM_targetCURRENT == FFECOM_targetFFE
2356 static void
2357 ffeste_subr_file_ (const char *kw, ffestpFile *spec)
2358 {
2359 if (!spec->kw_or_val_present)
2360 return;
2361 fputs (kw, dmpout);
2362 if (spec->value_present)
2363 {
2364 fputc ('=', dmpout);
2365 if (spec->value_is_label)
2366 {
2367 assert (spec->value_is_label == 2); /* Temporary checking only. */
2368 fprintf (dmpout, "%" ffelabValue_f "u",
2369 ffelab_value (spec->u.label));
2370 }
2371 else
2372 ffebld_dump (spec->u.expr);
2373 }
2374 fputc (',', dmpout);
2375 }
2376 #endif
2377
2378 /* Generate code for BACKSPACE/ENDFILE/REWIND. */
2379
2380 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2381 static void
2382 ffeste_subr_beru_ (ffestpBeruStmt *info, ffecomGfrt rt)
2383 {
2384 tree alist;
2385 bool iostat;
2386 bool errl;
2387
2388 ffeste_emit_line_note_ ();
2389
2390 #define specified(something) (info->beru_spec[something].kw_or_val_present)
2391
2392 iostat = specified (FFESTP_beruixIOSTAT);
2393 errl = specified (FFESTP_beruixERR);
2394
2395 #undef specified
2396
2397 /* ~~For now, we assume the unit number is specified and is not ASTERISK,
2398 because the FFE doesn't support BACKSPACE(*) and rejects a BACKSPACE
2399 without any unit specifier. f2c, however, supports the former
2400 construct. When it is time to add this feature to the FFE, which
2401 probably is fairly easy, ffestc_R919 and company will want to pass an
2402 ffestvUnit indicator of FFESTV_unitINTEXPR or _unitASTERISK to
2403 ffeste_R919 and company, and they will want to pass that same value to
2404 this function, and that argument will replace the constant _unitINTEXPR_
2405 in the call below. Right now, the default unit number, 6, is ignored. */
2406
2407 ffeste_start_stmt_ ();
2408
2409 if (errl)
2410 {
2411 /* Have ERR= specification. */
2412
2413 ffeste_io_err_
2414 = ffeste_io_abort_
2415 = ffecom_lookup_label
2416 (info->beru_spec[FFESTP_beruixERR].u.label);
2417 ffeste_io_abort_is_temp_ = FALSE;
2418 }
2419 else
2420 {
2421 /* No ERR= specification. */
2422
2423 ffeste_io_err_ = NULL_TREE;
2424
2425 if ((ffeste_io_abort_is_temp_ = iostat))
2426 ffeste_io_abort_ = ffecom_temp_label ();
2427 else
2428 ffeste_io_abort_ = NULL_TREE;
2429 }
2430
2431 if (iostat)
2432 {
2433 /* Have IOSTAT= specification. */
2434
2435 ffeste_io_iostat_is_temp_ = FALSE;
2436 ffeste_io_iostat_ = ffecom_expr
2437 (info->beru_spec[FFESTP_beruixIOSTAT].u.expr);
2438 }
2439 else if (ffeste_io_abort_ != NULL_TREE)
2440 {
2441 /* Have no IOSTAT= but have ERR=. */
2442
2443 ffeste_io_iostat_is_temp_ = TRUE;
2444 ffeste_io_iostat_
2445 = ffecom_make_tempvar ("beru", ffecom_integer_type_node,
2446 FFETARGET_charactersizeNONE, -1);
2447 }
2448 else
2449 {
2450 /* No IOSTAT= or ERR= specification. */
2451
2452 ffeste_io_iostat_is_temp_ = FALSE;
2453 ffeste_io_iostat_ = NULL_TREE;
2454 }
2455
2456 /* Now prescan, then convert, all the arguments. */
2457
2458 alist = ffeste_io_ialist_ (errl || iostat, FFESTV_unitINTEXPR,
2459 info->beru_spec[FFESTP_beruixUNIT].u.expr, 6);
2460
2461 /* Don't generate "if (iostat != 0) goto label;" if label is temp abort
2462 label, since we're gonna fall through to there anyway. */
2463
2464 ffeste_io_call_ (ffecom_call_gfrt (rt, alist, NULL_TREE),
2465 ! ffeste_io_abort_is_temp_);
2466
2467 /* If we've got a temp label, generate its code here. */
2468
2469 if (ffeste_io_abort_is_temp_)
2470 {
2471 DECL_INITIAL (ffeste_io_abort_) = error_mark_node;
2472 emit_nop ();
2473 expand_label (ffeste_io_abort_);
2474
2475 assert (ffeste_io_err_ == NULL_TREE);
2476 }
2477
2478 ffeste_end_stmt_ ();
2479 }
2480 #endif
2481
2482 /* END DO statement
2483
2484 Also invoked by _labeldef_branch_finish_ (or, in cases
2485 of errors, other _labeldef_ functions) when the label definition is
2486 for a DO-target (LOOPEND) label, once per matching/outstanding DO
2487 block on the stack. */
2488
2489 void
2490 ffeste_do (ffestw block)
2491 {
2492 #if FFECOM_targetCURRENT == FFECOM_targetFFE
2493 fputs ("+ END_DO\n", dmpout);
2494 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
2495 ffeste_emit_line_note_ ();
2496
2497 if (ffestw_do_tvar (block) == 0)
2498 {
2499 expand_end_loop (); /* DO WHILE and just DO. */
2500
2501 ffeste_end_block_ (block);
2502 }
2503 else
2504 ffeste_end_iterdo_ (block,
2505 ffestw_do_tvar (block),
2506 ffestw_do_incr_saved (block),
2507 ffestw_do_count_var (block));
2508 #else
2509 #error
2510 #endif
2511 }
2512
2513 /* End of statement following logical IF.
2514
2515 Applies to *only* logical IF, not to IF-THEN. */
2516
2517 void
2518 ffeste_end_R807 ()
2519 {
2520 #if FFECOM_targetCURRENT == FFECOM_targetFFE
2521 fputs ("+ END_IF\n", dmpout); /* Also see ffeste_R806. */
2522 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
2523 ffeste_emit_line_note_ ();
2524
2525 expand_end_cond ();
2526
2527 ffeste_end_block_ (NULL);
2528 #else
2529 #error
2530 #endif
2531 }
2532
2533 /* Generate "code" for branch label definition. */
2534
2535 void
2536 ffeste_labeldef_branch (ffelab label)
2537 {
2538 #if FFECOM_targetCURRENT == FFECOM_targetFFE
2539 fprintf (dmpout, "+ label %lu\n", ffelab_value (label));
2540 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
2541 {
2542 tree glabel;
2543
2544 glabel = ffecom_lookup_label (label);
2545 assert (glabel != NULL_TREE);
2546 if (TREE_CODE (glabel) == ERROR_MARK)
2547 return;
2548
2549 assert (DECL_INITIAL (glabel) == NULL_TREE);
2550
2551 DECL_INITIAL (glabel) = error_mark_node;
2552 DECL_SOURCE_FILE (glabel) = ffelab_definition_filename (label);
2553 DECL_SOURCE_LINE (glabel) = ffelab_definition_filelinenum (label);
2554
2555 emit_nop ();
2556
2557 expand_label (glabel);
2558 }
2559 #else
2560 #error
2561 #endif
2562 }
2563
2564 /* Generate "code" for FORMAT label definition. */
2565
2566 void
2567 ffeste_labeldef_format (ffelab label)
2568 {
2569 #if FFECOM_targetCURRENT == FFECOM_targetFFE
2570 fprintf (dmpout, "$ label %lu\n", ffelab_value (label));
2571 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
2572 ffeste_label_formatdef_ = label;
2573 #else
2574 #error
2575 #endif
2576 }
2577
2578 /* Assignment statement (outside of WHERE). */
2579
2580 void
2581 ffeste_R737A (ffebld dest, ffebld source)
2582 {
2583 ffeste_check_simple_ ();
2584
2585 #if FFECOM_targetCURRENT == FFECOM_targetFFE
2586 fputs ("+ let ", dmpout);
2587 ffebld_dump (dest);
2588 fputs ("=", dmpout);
2589 ffebld_dump (source);
2590 fputc ('\n', dmpout);
2591 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
2592 ffeste_emit_line_note_ ();
2593
2594 ffeste_start_stmt_ ();
2595
2596 ffecom_expand_let_stmt (dest, source);
2597
2598 ffeste_end_stmt_ ();
2599 #else
2600 #error
2601 #endif
2602 }
2603
2604 /* Block IF (IF-THEN) statement. */
2605
2606 void
2607 ffeste_R803 (ffestw block, ffebld expr)
2608 {
2609 ffeste_check_simple_ ();
2610
2611 #if FFECOM_targetCURRENT == FFECOM_targetFFE
2612 fputs ("+ IF_block (", dmpout);
2613 ffebld_dump (expr);
2614 fputs (")\n", dmpout);
2615 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
2616 {
2617 tree temp;
2618
2619 ffeste_emit_line_note_ ();
2620
2621 ffeste_start_block_ (block);
2622
2623 temp = ffecom_make_tempvar ("ifthen", integer_type_node,
2624 FFETARGET_charactersizeNONE, -1);
2625
2626 ffeste_start_stmt_ ();
2627
2628 ffecom_prepare_expr (expr);
2629
2630 if (ffecom_prepare_end ())
2631 {
2632 tree result;
2633
2634 result = ffecom_modify (void_type_node,
2635 temp,
2636 ffecom_truth_value (ffecom_expr (expr)));
2637
2638 expand_expr_stmt (result);
2639
2640 ffeste_end_stmt_ ();
2641 }
2642 else
2643 {
2644 ffeste_end_stmt_ ();
2645
2646 temp = ffecom_truth_value (ffecom_expr (expr));
2647 }
2648
2649 expand_start_cond (temp, 0);
2650
2651 /* No fake `else' constructs introduced (yet). */
2652 ffestw_set_ifthen_fake_else (block, 0);
2653 }
2654 #else
2655 #error
2656 #endif
2657 }
2658
2659 /* ELSE IF statement. */
2660
2661 void
2662 ffeste_R804 (ffestw block, ffebld expr)
2663 {
2664 ffeste_check_simple_ ();
2665
2666 #if FFECOM_targetCURRENT == FFECOM_targetFFE
2667 fputs ("+ ELSE_IF (", dmpout);
2668 ffebld_dump (expr);
2669 fputs (")\n", dmpout);
2670 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
2671 {
2672 tree temp;
2673
2674 ffeste_emit_line_note_ ();
2675
2676 /* Since ELSEIF(expr) might require preparations for expr,
2677 implement as ELSE; prepare-expr; IF (expr) THEN ...; ENDIF. */
2678
2679 expand_start_else ();
2680
2681 ffeste_start_block_ (block);
2682
2683 temp = ffecom_make_tempvar ("elseif", integer_type_node,
2684 FFETARGET_charactersizeNONE, -1);
2685
2686 ffeste_start_stmt_ ();
2687
2688 ffecom_prepare_expr (expr);
2689
2690 if (ffecom_prepare_end ())
2691 {
2692 tree result;
2693
2694 result = ffecom_modify (void_type_node,
2695 temp,
2696 ffecom_truth_value (ffecom_expr (expr)));
2697
2698 expand_expr_stmt (result);
2699
2700 ffeste_end_stmt_ ();
2701 }
2702 else
2703 {
2704 /* In this case, we could probably have used expand_start_elseif
2705 instead, saving the need for a fake `else' construct. But,
2706 until it's clear that'd improve performance, it's easier this
2707 way, since we have to expand_start_else before we get to this
2708 test, given the current design. */
2709
2710 ffeste_end_stmt_ ();
2711
2712 temp = ffecom_truth_value (ffecom_expr (expr));
2713 }
2714
2715 expand_start_cond (temp, 0);
2716
2717 /* Increment number of fake `else' constructs introduced. */
2718 ffestw_set_ifthen_fake_else (block,
2719 ffestw_ifthen_fake_else (block) + 1);
2720 }
2721 #else
2722 #error
2723 #endif
2724 }
2725
2726 /* ELSE statement. */
2727
2728 void
2729 ffeste_R805 (ffestw block UNUSED)
2730 {
2731 ffeste_check_simple_ ();
2732
2733 #if FFECOM_targetCURRENT == FFECOM_targetFFE
2734 fputs ("+ ELSE\n", dmpout);
2735 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
2736 ffeste_emit_line_note_ ();
2737
2738 expand_start_else ();
2739 #else
2740 #error
2741 #endif
2742 }
2743
2744 /* END IF statement. */
2745
2746 void
2747 ffeste_R806 (ffestw block)
2748 {
2749 #if FFECOM_targetCURRENT == FFECOM_targetFFE
2750 fputs ("+ END_IF_then\n", dmpout); /* Also see ffeste_shriek_if_. */
2751 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
2752 {
2753 int i = ffestw_ifthen_fake_else (block) + 1;
2754
2755 ffeste_emit_line_note_ ();
2756
2757 for (; i; --i)
2758 {
2759 expand_end_cond ();
2760
2761 ffeste_end_block_ (block);
2762 }
2763 }
2764 #else
2765 #error
2766 #endif
2767 }
2768
2769 /* Logical IF statement. */
2770
2771 void
2772 ffeste_R807 (ffebld expr)
2773 {
2774 ffeste_check_simple_ ();
2775
2776 #if FFECOM_targetCURRENT == FFECOM_targetFFE
2777 fputs ("+ IF_logical (", dmpout);
2778 ffebld_dump (expr);
2779 fputs (")\n", dmpout);
2780 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
2781 {
2782 tree temp;
2783
2784 ffeste_emit_line_note_ ();
2785
2786 ffeste_start_block_ (NULL);
2787
2788 temp = ffecom_make_tempvar ("if", integer_type_node,
2789 FFETARGET_charactersizeNONE, -1);
2790
2791 ffeste_start_stmt_ ();
2792
2793 ffecom_prepare_expr (expr);
2794
2795 if (ffecom_prepare_end ())
2796 {
2797 tree result;
2798
2799 result = ffecom_modify (void_type_node,
2800 temp,
2801 ffecom_truth_value (ffecom_expr (expr)));
2802
2803 expand_expr_stmt (result);
2804
2805 ffeste_end_stmt_ ();
2806 }
2807 else
2808 {
2809 ffeste_end_stmt_ ();
2810
2811 temp = ffecom_truth_value (ffecom_expr (expr));
2812 }
2813
2814 expand_start_cond (temp, 0);
2815 }
2816 #else
2817 #error
2818 #endif
2819 }
2820
2821 /* SELECT CASE statement. */
2822
2823 void
2824 ffeste_R809 (ffestw block, ffebld expr)
2825 {
2826 ffeste_check_simple_ ();
2827
2828 #if FFECOM_targetCURRENT == FFECOM_targetFFE
2829 fputs ("+ SELECT_CASE (", dmpout);
2830 ffebld_dump (expr);
2831 fputs (")\n", dmpout);
2832 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
2833 ffeste_emit_line_note_ ();
2834
2835 ffeste_start_block_ (block);
2836
2837 if ((expr == NULL)
2838 || (ffeinfo_basictype (ffebld_info (expr))
2839 == FFEINFO_basictypeANY))
2840 ffestw_set_select_texpr (block, error_mark_node);
2841 else if (ffeinfo_basictype (ffebld_info (expr))
2842 == FFEINFO_basictypeCHARACTER)
2843 {
2844 /* ~~~Someday handle CHARACTER*1, CHARACTER*N */
2845
2846 ffebad_start_msg ("SELECT CASE on CHARACTER type (at %0) not supported -- sorry",
2847 FFEBAD_severityFATAL);
2848 ffebad_here (0, ffestw_line (block), ffestw_col (block));
2849 ffebad_finish ();
2850 ffestw_set_select_texpr (block, error_mark_node);
2851 }
2852 else
2853 {
2854 tree result;
2855 tree texpr;
2856
2857 result = ffecom_make_tempvar ("select", ffecom_type_expr (expr),
2858 ffeinfo_size (ffebld_info (expr)),
2859 -1);
2860
2861 ffeste_start_stmt_ ();
2862
2863 ffecom_prepare_expr (expr);
2864
2865 ffecom_prepare_end ();
2866
2867 texpr = ffecom_expr (expr);
2868
2869 assert (TYPE_MAIN_VARIANT (TREE_TYPE (texpr))
2870 == TYPE_MAIN_VARIANT (TREE_TYPE (result)));
2871
2872 texpr = ffecom_modify (void_type_node,
2873 result,
2874 texpr);
2875 expand_expr_stmt (texpr);
2876
2877 ffeste_end_stmt_ ();
2878
2879 expand_start_case (1, result, TREE_TYPE (result),
2880 "SELECT CASE statement");
2881 ffestw_set_select_texpr (block, texpr);
2882 ffestw_set_select_break (block, FALSE);
2883 }
2884 #else
2885 #error
2886 #endif
2887 }
2888
2889 /* CASE statement.
2890
2891 If casenum is 0, it's CASE DEFAULT. Else it's the case ranges at
2892 the start of the first_stmt list in the select object at the top of
2893 the stack that match casenum. */
2894
2895 void
2896 ffeste_R810 (ffestw block, unsigned long casenum)
2897 {
2898 ffestwSelect s = ffestw_select (block);
2899 ffestwCase c;
2900
2901 ffeste_check_simple_ ();
2902
2903 if (s->first_stmt == (ffestwCase) &s->first_rel)
2904 c = NULL;
2905 else
2906 c = s->first_stmt;
2907
2908 #if FFECOM_targetCURRENT == FFECOM_targetFFE
2909 if ((c == NULL) || (casenum != c->casenum))
2910 {
2911 if (casenum == 0) /* Intentional CASE DEFAULT. */
2912 fputs ("+ CASE_DEFAULT", dmpout);
2913 }
2914 else
2915 {
2916 bool comma = FALSE;
2917
2918 fputs ("+ CASE (", dmpout);
2919 do
2920 {
2921 if (comma)
2922 fputc (',', dmpout);
2923 else
2924 comma = TRUE;
2925 if (c->low != NULL)
2926 ffebld_constant_dump (c->low);
2927 if (c->low != c->high)
2928 {
2929 fputc (':', dmpout);
2930 if (c->high != NULL)
2931 ffebld_constant_dump (c->high);
2932 }
2933 c = c->next_stmt;
2934 /* Unlink prev. */
2935 c->previous_stmt->previous_stmt->next_stmt = c;
2936 c->previous_stmt = c->previous_stmt->previous_stmt;
2937 }
2938 while ((c != (ffestwCase) &s->first_rel) && (casenum == c->casenum));
2939 fputc (')', dmpout);
2940 }
2941
2942 fputc ('\n', dmpout);
2943 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
2944 {
2945 tree texprlow;
2946 tree texprhigh;
2947 tree tlabel;
2948 int pushok;
2949 tree duplicate;
2950
2951 ffeste_emit_line_note_ ();
2952
2953 if (ffestw_select_texpr (block) == error_mark_node)
2954 return;
2955
2956 /* ~~~Someday handle CHARACTER*1, CHARACTER*N */
2957
2958 tlabel = build_decl (LABEL_DECL, NULL_TREE, NULL_TREE);
2959
2960 if (ffestw_select_break (block))
2961 expand_exit_something ();
2962 else
2963 ffestw_set_select_break (block, TRUE);
2964
2965 if ((c == NULL) || (casenum != c->casenum))
2966 {
2967 if (casenum == 0) /* Intentional CASE DEFAULT. */
2968 {
2969 pushok = pushcase (NULL_TREE, 0, tlabel, &duplicate);
2970 assert (pushok == 0);
2971 }
2972 }
2973 else
2974 do
2975 {
2976 texprlow = (c->low == NULL) ? NULL_TREE
2977 : ffecom_constantunion (&ffebld_constant_union (c->low), s->type,
2978 s->kindtype, ffecom_tree_type[s->type][s->kindtype]);
2979 if (c->low != c->high)
2980 {
2981 texprhigh = (c->high == NULL) ? NULL_TREE
2982 : ffecom_constantunion (&ffebld_constant_union (c->high),
2983 s->type, s->kindtype, ffecom_tree_type[s->type][s->kindtype]);
2984 pushok = pushcase_range (texprlow, texprhigh, convert,
2985 tlabel, &duplicate);
2986 }
2987 else
2988 pushok = pushcase (texprlow, convert, tlabel, &duplicate);
2989 assert (pushok == 0);
2990 c = c->next_stmt;
2991 /* Unlink prev. */
2992 c->previous_stmt->previous_stmt->next_stmt = c;
2993 c->previous_stmt = c->previous_stmt->previous_stmt;
2994 }
2995 while ((c != (ffestwCase) &s->first_rel) && (casenum == c->casenum));
2996
2997 clear_momentary ();
2998 }
2999 #else
3000 #error
3001 #endif
3002 }
3003
3004 /* END SELECT statement. */
3005
3006 void
3007 ffeste_R811 (ffestw block)
3008 {
3009 #if FFECOM_targetCURRENT == FFECOM_targetFFE
3010 fputs ("+ END_SELECT\n", dmpout);
3011 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
3012 ffeste_emit_line_note_ ();
3013
3014 /* ~~~Someday handle CHARACTER*1, CHARACTER*N */
3015
3016 if (TREE_CODE (ffestw_select_texpr (block)) != ERROR_MARK)
3017 expand_end_case (ffestw_select_texpr (block));
3018
3019 ffeste_end_block_ (block);
3020 #else
3021 #error
3022 #endif
3023 }
3024
3025 /* Iterative DO statement. */
3026
3027 void
3028 ffeste_R819A (ffestw block, ffelab label UNUSED, ffebld var,
3029 ffebld start, ffelexToken start_token,
3030 ffebld end, ffelexToken end_token,
3031 ffebld incr, ffelexToken incr_token)
3032 {
3033 ffeste_check_simple_ ();
3034
3035 #if FFECOM_targetCURRENT == FFECOM_targetFFE
3036 if ((ffebld_op (incr) == FFEBLD_opCONTER)
3037 && (ffebld_constant_is_zero (ffebld_conter (incr))))
3038 {
3039 ffebad_start (FFEBAD_DO_STEP_ZERO);
3040 ffebad_here (0, ffelex_token_where_line (incr_token),
3041 ffelex_token_where_column (incr_token));
3042 ffebad_string ("Iterative DO loop");
3043 ffebad_finish ();
3044 /* Don't bother replacing it with 1 yet. */
3045 }
3046
3047 if (label == NULL)
3048 fputs ("+ DO_iterative_nonlabeled (", dmpout);
3049 else
3050 fprintf (dmpout, "+ DO_iterative_labeled %lu (", ffelab_value (label));
3051 ffebld_dump (var);
3052 fputc ('=', dmpout);
3053 ffebld_dump (start);
3054 fputc (',', dmpout);
3055 ffebld_dump (end);
3056 fputc (',', dmpout);
3057 ffebld_dump (incr);
3058 fputs (")\n", dmpout);
3059 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
3060 {
3061 ffeste_emit_line_note_ ();
3062
3063 ffeste_begin_iterdo_ (block, NULL, NULL, NULL,
3064 var,
3065 start, start_token,
3066 end, end_token,
3067 incr, incr_token,
3068 "Iterative DO loop");
3069 }
3070 #else
3071 #error
3072 #endif
3073 }
3074
3075 /* DO WHILE statement. */
3076
3077 void
3078 ffeste_R819B (ffestw block, ffelab label UNUSED, ffebld expr)
3079 {
3080 ffeste_check_simple_ ();
3081
3082 #if FFECOM_targetCURRENT == FFECOM_targetFFE
3083 if (label == NULL)
3084 fputs ("+ DO_WHILE_nonlabeled (", dmpout);
3085 else
3086 fprintf (dmpout, "+ DO_WHILE_labeled %lu (", ffelab_value (label));
3087 ffebld_dump (expr);
3088 fputs (")\n", dmpout);
3089 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
3090 {
3091 tree result;
3092
3093 ffeste_emit_line_note_ ();
3094
3095 ffeste_start_block_ (block);
3096
3097 if (expr)
3098 {
3099 struct nesting *loop;
3100 tree mod;
3101
3102 result = ffecom_make_tempvar ("dowhile", integer_type_node,
3103 FFETARGET_charactersizeNONE, -1);
3104 loop = expand_start_loop (1);
3105
3106 ffeste_start_stmt_ ();
3107
3108 ffecom_prepare_expr (expr);
3109
3110 ffecom_prepare_end ();
3111
3112 mod = ffecom_modify (void_type_node,
3113 result,
3114 ffecom_truth_value (ffecom_expr (expr)));
3115 expand_expr_stmt (mod);
3116
3117 ffeste_end_stmt_ ();
3118
3119 ffestw_set_do_hook (block, loop);
3120 expand_exit_loop_if_false (0, result);
3121 }
3122 else
3123 ffestw_set_do_hook (block, expand_start_loop (1));
3124
3125 ffestw_set_do_tvar (block, NULL_TREE);
3126 }
3127 #else
3128 #error
3129 #endif
3130 }
3131
3132 /* END DO statement.
3133
3134 This is the MIL-STD 1753 END DO. It's syntactic sugar, similar to
3135 CONTINUE (except that it has to have a label that is the target of
3136 one or more iterative DO statement), not the Fortran-90 structured
3137 END DO, which is handled elsewhere, as is the actual mechanism of
3138 ending an iterative DO statement, even one that ends at a label. */
3139
3140 void
3141 ffeste_R825 ()
3142 {
3143 ffeste_check_simple_ ();
3144
3145 #if FFECOM_targetCURRENT == FFECOM_targetFFE
3146 fputs ("+ END_DO_sugar\n", dmpout);
3147 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
3148 ffeste_emit_line_note_ ();
3149
3150 emit_nop ();
3151 #else
3152 #error
3153 #endif
3154 }
3155
3156 /* CYCLE statement. */
3157
3158 void
3159 ffeste_R834 (ffestw block)
3160 {
3161 ffeste_check_simple_ ();
3162
3163 #if FFECOM_targetCURRENT == FFECOM_targetFFE
3164 fprintf (dmpout, "+ CYCLE block #%lu\n", ffestw_blocknum (block));
3165 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
3166 ffeste_emit_line_note_ ();
3167
3168 expand_continue_loop (ffestw_do_hook (block));
3169 #else
3170 #error
3171 #endif
3172 }
3173
3174 /* EXIT statement. */
3175
3176 void
3177 ffeste_R835 (ffestw block)
3178 {
3179 ffeste_check_simple_ ();
3180
3181 #if FFECOM_targetCURRENT == FFECOM_targetFFE
3182 fprintf (dmpout, "+ EXIT block #%lu\n", ffestw_blocknum (block));
3183 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
3184 ffeste_emit_line_note_ ();
3185
3186 expand_exit_loop (ffestw_do_hook (block));
3187 #else
3188 #error
3189 #endif
3190 }
3191
3192 /* GOTO statement. */
3193
3194 void
3195 ffeste_R836 (ffelab label)
3196 {
3197 ffeste_check_simple_ ();
3198
3199 #if FFECOM_targetCURRENT == FFECOM_targetFFE
3200 fprintf (dmpout, "+ GOTO %lu\n", ffelab_value (label));
3201 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
3202 {
3203 tree glabel;
3204
3205 ffeste_emit_line_note_ ();
3206
3207 glabel = ffecom_lookup_label (label);
3208 if ((glabel != NULL_TREE)
3209 && (TREE_CODE (glabel) != ERROR_MARK))
3210 {
3211 expand_goto (glabel);
3212 TREE_USED (glabel) = 1;
3213 }
3214 }
3215 #else
3216 #error
3217 #endif
3218 }
3219
3220 /* Computed GOTO statement. */
3221
3222 void
3223 ffeste_R837 (ffelab *labels, int count, ffebld expr)
3224 {
3225 int i;
3226
3227 ffeste_check_simple_ ();
3228
3229 #if FFECOM_targetCURRENT == FFECOM_targetFFE
3230 fputs ("+ CGOTO (", dmpout);
3231 for (i = 0; i < count; ++i)
3232 {
3233 if (i != 0)
3234 fputc (',', dmpout);
3235 fprintf (dmpout, "%" ffelabValue_f "u", ffelab_value (labels[i]));
3236 }
3237 fputs ("),", dmpout);
3238 ffebld_dump (expr);
3239 fputc ('\n', dmpout);
3240 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
3241 {
3242 tree texpr;
3243 tree value;
3244 tree tlabel;
3245 int pushok;
3246 tree duplicate;
3247
3248 ffeste_emit_line_note_ ();
3249
3250 ffeste_start_stmt_ ();
3251
3252 ffecom_prepare_expr (expr);
3253
3254 ffecom_prepare_end ();
3255
3256 texpr = ffecom_expr (expr);
3257
3258 expand_start_case (0, texpr, TREE_TYPE (texpr), "computed GOTO statement");
3259
3260 for (i = 0; i < count; ++i)
3261 {
3262 value = build_int_2 (i + 1, 0);
3263 tlabel = build_decl (LABEL_DECL, NULL_TREE, NULL_TREE);
3264
3265 pushok = pushcase (value, convert, tlabel, &duplicate);
3266 assert (pushok == 0);
3267
3268 tlabel = ffecom_lookup_label (labels[i]);
3269 if ((tlabel == NULL_TREE)
3270 || (TREE_CODE (tlabel) == ERROR_MARK))
3271 continue;
3272
3273 expand_goto (tlabel);
3274 TREE_USED (tlabel) = 1;
3275 }
3276 expand_end_case (texpr);
3277
3278 ffeste_end_stmt_ ();
3279 }
3280 #else
3281 #error
3282 #endif
3283 }
3284
3285 /* ASSIGN statement. */
3286
3287 void
3288 ffeste_R838 (ffelab label, ffebld target)
3289 {
3290 ffeste_check_simple_ ();
3291
3292 #if FFECOM_targetCURRENT == FFECOM_targetFFE
3293 fprintf (dmpout, "+ ASSIGN %lu TO ", ffelab_value (label));
3294 ffebld_dump (target);
3295 fputc ('\n', dmpout);
3296 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
3297 {
3298 tree expr_tree;
3299 tree label_tree;
3300 tree target_tree;
3301
3302 ffeste_emit_line_note_ ();
3303
3304 /* No need to call ffeste_start_stmt_(), as the sorts of expressions
3305 seen here should never require use of temporaries. */
3306
3307 label_tree = ffecom_lookup_label (label);
3308 if ((label_tree != NULL_TREE)
3309 && (TREE_CODE (label_tree) != ERROR_MARK))
3310 {
3311 label_tree = ffecom_1 (ADDR_EXPR,
3312 build_pointer_type (void_type_node),
3313 label_tree);
3314 TREE_CONSTANT (label_tree) = 1;
3315
3316 target_tree = ffecom_expr_assign_w (target);
3317 if (GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (target_tree)))
3318 < GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (label_tree))))
3319 error ("ASSIGN to variable that is too small");
3320
3321 label_tree = convert (TREE_TYPE (target_tree), label_tree);
3322
3323 expr_tree = ffecom_modify (void_type_node,
3324 target_tree,
3325 label_tree);
3326 expand_expr_stmt (expr_tree);
3327
3328 clear_momentary ();
3329 }
3330 }
3331 #else
3332 #error
3333 #endif
3334 }
3335
3336 /* Assigned GOTO statement. */
3337
3338 void
3339 ffeste_R839 (ffebld target)
3340 {
3341 ffeste_check_simple_ ();
3342
3343 #if FFECOM_targetCURRENT == FFECOM_targetFFE
3344 fputs ("+ AGOTO ", dmpout);
3345 ffebld_dump (target);
3346 fputc ('\n', dmpout);
3347 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
3348 {
3349 tree t;
3350
3351 ffeste_emit_line_note_ ();
3352
3353 /* No need to call ffeste_start_stmt_(), as the sorts of expressions
3354 seen here should never require use of temporaries. */
3355
3356 t = ffecom_expr_assign (target);
3357 if (GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (t)))
3358 < GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node))))
3359 error ("ASSIGNed GOTO target variable is too small");
3360
3361 expand_computed_goto (convert (TREE_TYPE (null_pointer_node), t));
3362
3363 clear_momentary ();
3364 }
3365 #else
3366 #error
3367 #endif
3368 }
3369
3370 /* Arithmetic IF statement. */
3371
3372 void
3373 ffeste_R840 (ffebld expr, ffelab neg, ffelab zero, ffelab pos)
3374 {
3375 ffeste_check_simple_ ();
3376
3377 #if FFECOM_targetCURRENT == FFECOM_targetFFE
3378 fputs ("+ IF_arithmetic (", dmpout);
3379 ffebld_dump (expr);
3380 fprintf (dmpout, ") %" ffelabValue_f "u,%" ffelabValue_f "u,%" ffelabValue_f "u\n",
3381 ffelab_value (neg), ffelab_value (zero), ffelab_value (pos));
3382 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
3383 {
3384 tree gneg = ffecom_lookup_label (neg);
3385 tree gzero = ffecom_lookup_label (zero);
3386 tree gpos = ffecom_lookup_label (pos);
3387 tree texpr;
3388
3389 ffeste_emit_line_note_ ();
3390
3391 if ((gneg == NULL_TREE) || (gzero == NULL_TREE) || (gpos == NULL_TREE))
3392 return;
3393 if ((TREE_CODE (gneg) == ERROR_MARK)
3394 || (TREE_CODE (gzero) == ERROR_MARK)
3395 || (TREE_CODE (gpos) == ERROR_MARK))
3396 return;
3397
3398 ffeste_start_stmt_ ();
3399
3400 ffecom_prepare_expr (expr);
3401
3402 ffecom_prepare_end ();
3403
3404 if (neg == zero)
3405 {
3406 if (neg == pos)
3407 expand_goto (gzero);
3408 else
3409 {
3410 /* IF (expr.LE.0) THEN GOTO neg/zero ELSE GOTO pos. */
3411 texpr = ffecom_expr (expr);
3412 texpr = ffecom_2 (LE_EXPR, integer_type_node,
3413 texpr,
3414 convert (TREE_TYPE (texpr),
3415 integer_zero_node));
3416 expand_start_cond (ffecom_truth_value (texpr), 0);
3417 expand_goto (gzero);
3418 expand_start_else ();
3419 expand_goto (gpos);
3420 expand_end_cond ();
3421 }
3422 }
3423 else if (neg == pos)
3424 {
3425 /* IF (expr.NE.0) THEN GOTO neg/pos ELSE GOTO zero. */
3426 texpr = ffecom_expr (expr);
3427 texpr = ffecom_2 (NE_EXPR, integer_type_node,
3428 texpr,
3429 convert (TREE_TYPE (texpr),
3430 integer_zero_node));
3431 expand_start_cond (ffecom_truth_value (texpr), 0);
3432 expand_goto (gneg);
3433 expand_start_else ();
3434 expand_goto (gzero);
3435 expand_end_cond ();
3436 }
3437 else if (zero == pos)
3438 {
3439 /* IF (expr.GE.0) THEN GOTO zero/pos ELSE GOTO neg. */
3440 texpr = ffecom_expr (expr);
3441 texpr = ffecom_2 (GE_EXPR, integer_type_node,
3442 texpr,
3443 convert (TREE_TYPE (texpr),
3444 integer_zero_node));
3445 expand_start_cond (ffecom_truth_value (texpr), 0);
3446 expand_goto (gzero);
3447 expand_start_else ();
3448 expand_goto (gneg);
3449 expand_end_cond ();
3450 }
3451 else
3452 {
3453 /* Use a SAVE_EXPR in combo with:
3454 IF (expr.LT.0) THEN GOTO neg
3455 ELSEIF (expr.GT.0) THEN GOTO pos
3456 ELSE GOTO zero. */
3457 tree expr_saved = ffecom_save_tree (ffecom_expr (expr));
3458
3459 texpr = ffecom_2 (LT_EXPR, integer_type_node,
3460 expr_saved,
3461 convert (TREE_TYPE (expr_saved),
3462 integer_zero_node));
3463 expand_start_cond (ffecom_truth_value (texpr), 0);
3464 expand_goto (gneg);
3465 texpr = ffecom_2 (GT_EXPR, integer_type_node,
3466 expr_saved,
3467 convert (TREE_TYPE (expr_saved),
3468 integer_zero_node));
3469 expand_start_elseif (ffecom_truth_value (texpr));
3470 expand_goto (gpos);
3471 expand_start_else ();
3472 expand_goto (gzero);
3473 expand_end_cond ();
3474 }
3475
3476 ffeste_end_stmt_ ();
3477 }
3478 #else
3479 #error
3480 #endif
3481 }
3482
3483 /* CONTINUE statement. */
3484
3485 void
3486 ffeste_R841 ()
3487 {
3488 ffeste_check_simple_ ();
3489
3490 #if FFECOM_targetCURRENT == FFECOM_targetFFE
3491 fputs ("+ CONTINUE\n", dmpout);
3492 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
3493 ffeste_emit_line_note_ ();
3494
3495 emit_nop ();
3496 #else
3497 #error
3498 #endif
3499 }
3500
3501 /* STOP statement. */
3502
3503 void
3504 ffeste_R842 (ffebld expr)
3505 {
3506 ffeste_check_simple_ ();
3507
3508 #if FFECOM_targetCURRENT == FFECOM_targetFFE
3509 if (expr == NULL)
3510 {
3511 fputs ("+ STOP\n", dmpout);
3512 }
3513 else
3514 {
3515 fputs ("+ STOP_coded ", dmpout);
3516 ffebld_dump (expr);
3517 fputc ('\n', dmpout);
3518 }
3519 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
3520 {
3521 tree callit;
3522 ffelexToken msg;
3523
3524 ffeste_emit_line_note_ ();
3525
3526 if ((expr == NULL)
3527 || (ffeinfo_basictype (ffebld_info (expr))
3528 == FFEINFO_basictypeANY))
3529 {
3530 msg = ffelex_token_new_character ("", ffelex_token_where_line
3531 (ffesta_tokens[0]), ffelex_token_where_column
3532 (ffesta_tokens[0]));
3533 expr = ffebld_new_conter (ffebld_constant_new_characterdefault
3534 (msg));
3535 ffelex_token_kill (msg);
3536 ffebld_set_info (expr, ffeinfo_new (FFEINFO_basictypeCHARACTER,
3537 FFEINFO_kindtypeCHARACTERDEFAULT, 0, FFEINFO_kindENTITY,
3538 FFEINFO_whereCONSTANT, 0));
3539 }
3540 else if (ffeinfo_basictype (ffebld_info (expr))
3541 == FFEINFO_basictypeINTEGER)
3542 {
3543 char num[50];
3544
3545 assert (ffebld_op (expr) == FFEBLD_opCONTER);
3546 assert (ffeinfo_kindtype (ffebld_info (expr))
3547 == FFEINFO_kindtypeINTEGERDEFAULT);
3548 sprintf (num, "%" ffetargetIntegerDefault_f "d",
3549 ffebld_constant_integer1 (ffebld_conter (expr)));
3550 msg = ffelex_token_new_character (num, ffelex_token_where_line
3551 (ffesta_tokens[0]), ffelex_token_where_column
3552 (ffesta_tokens[0]));
3553 expr = ffebld_new_conter (ffebld_constant_new_characterdefault
3554 (msg));
3555 ffelex_token_kill (msg);
3556 ffebld_set_info (expr, ffeinfo_new (FFEINFO_basictypeCHARACTER,
3557 FFEINFO_kindtypeCHARACTERDEFAULT, 0, FFEINFO_kindENTITY,
3558 FFEINFO_whereCONSTANT, 0));
3559 }
3560 else
3561 {
3562 assert (ffeinfo_basictype (ffebld_info (expr))
3563 == FFEINFO_basictypeCHARACTER);
3564 assert (ffebld_op (expr) == FFEBLD_opCONTER);
3565 assert (ffeinfo_kindtype (ffebld_info (expr))
3566 == FFEINFO_kindtypeCHARACTERDEFAULT);
3567 }
3568
3569 /* No need to call ffeste_start_stmt_(), as the sorts of expressions
3570 seen here should never require use of temporaries. */
3571
3572 callit = ffecom_call_gfrt (FFECOM_gfrtSTOP,
3573 ffecom_list_ptr_to_expr (ffebld_new_item (expr, NULL)),
3574 NULL_TREE);
3575 TREE_SIDE_EFFECTS (callit) = 1;
3576
3577 expand_expr_stmt (callit);
3578
3579 clear_momentary ();
3580 }
3581 #else
3582 #error
3583 #endif
3584 }
3585
3586 /* PAUSE statement. */
3587
3588 void
3589 ffeste_R843 (ffebld expr)
3590 {
3591 ffeste_check_simple_ ();
3592
3593 #if FFECOM_targetCURRENT == FFECOM_targetFFE
3594 if (expr == NULL)
3595 {
3596 fputs ("+ PAUSE\n", dmpout);
3597 }
3598 else
3599 {
3600 fputs ("+ PAUSE_coded ", dmpout);
3601 ffebld_dump (expr);
3602 fputc ('\n', dmpout);
3603 }
3604 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
3605 {
3606 tree callit;
3607 ffelexToken msg;
3608
3609 ffeste_emit_line_note_ ();
3610
3611 if ((expr == NULL)
3612 || (ffeinfo_basictype (ffebld_info (expr))
3613 == FFEINFO_basictypeANY))
3614 {
3615 msg = ffelex_token_new_character ("", ffelex_token_where_line
3616 (ffesta_tokens[0]), ffelex_token_where_column
3617 (ffesta_tokens[0]));
3618 expr = ffebld_new_conter (ffebld_constant_new_characterdefault
3619 (msg));
3620 ffelex_token_kill (msg);
3621 ffebld_set_info (expr, ffeinfo_new (FFEINFO_basictypeCHARACTER,
3622 FFEINFO_kindtypeCHARACTERDEFAULT, 0, FFEINFO_kindENTITY,
3623 FFEINFO_whereCONSTANT, 0));
3624 }
3625 else if (ffeinfo_basictype (ffebld_info (expr))
3626 == FFEINFO_basictypeINTEGER)
3627 {
3628 char num[50];
3629
3630 assert (ffebld_op (expr) == FFEBLD_opCONTER);
3631 assert (ffeinfo_kindtype (ffebld_info (expr))
3632 == FFEINFO_kindtypeINTEGERDEFAULT);
3633 sprintf (num, "%" ffetargetIntegerDefault_f "d",
3634 ffebld_constant_integer1 (ffebld_conter (expr)));
3635 msg = ffelex_token_new_character (num, ffelex_token_where_line
3636 (ffesta_tokens[0]), ffelex_token_where_column
3637 (ffesta_tokens[0]));
3638 expr = ffebld_new_conter (ffebld_constant_new_characterdefault
3639 (msg));
3640 ffelex_token_kill (msg);
3641 ffebld_set_info (expr, ffeinfo_new (FFEINFO_basictypeCHARACTER,
3642 FFEINFO_kindtypeCHARACTERDEFAULT, 0, FFEINFO_kindENTITY,
3643 FFEINFO_whereCONSTANT, 0));
3644 }
3645 else
3646 {
3647 assert (ffeinfo_basictype (ffebld_info (expr))
3648 == FFEINFO_basictypeCHARACTER);
3649 assert (ffebld_op (expr) == FFEBLD_opCONTER);
3650 assert (ffeinfo_kindtype (ffebld_info (expr))
3651 == FFEINFO_kindtypeCHARACTERDEFAULT);
3652 }
3653
3654 /* No need to call ffeste_start_stmt_(), as the sorts of expressions
3655 seen here should never require use of temporaries. */
3656
3657 callit = ffecom_call_gfrt (FFECOM_gfrtPAUSE,
3658 ffecom_list_ptr_to_expr (ffebld_new_item (expr, NULL)),
3659 NULL_TREE);
3660 TREE_SIDE_EFFECTS (callit) = 1;
3661
3662 expand_expr_stmt (callit);
3663
3664 clear_momentary ();
3665 }
3666 #if 0 /* Old approach for phantom g77 run-time
3667 library. */
3668 {
3669 tree callit;
3670
3671 ffeste_emit_line_note_ ();
3672
3673 if (expr == NULL)
3674 callit = ffecom_call_gfrt (FFECOM_gfrtPAUSENIL, NULL_TREE, NULL_TREE);
3675 else if (ffeinfo_basictype (ffebld_info (expr))
3676 == FFEINFO_basictypeINTEGER)
3677 callit = ffecom_call_gfrt (FFECOM_gfrtPAUSEINT,
3678 ffecom_list_ptr_to_expr (ffebld_new_item (expr, NULL)),
3679 NULL_TREE);
3680 else if (ffeinfo_basictype (ffebld_info (expr))
3681 == FFEINFO_basictypeCHARACTER)
3682 callit = ffecom_call_gfrt (FFECOM_gfrtPAUSECHAR,
3683 ffecom_list_ptr_to_expr (ffebld_new_item (expr, NULL)),
3684 NULL_TREE);
3685 else
3686 abort ();
3687 TREE_SIDE_EFFECTS (callit) = 1;
3688
3689 expand_expr_stmt (callit);
3690
3691 clear_momentary ();
3692 }
3693 #endif
3694 #else
3695 #error
3696 #endif
3697 }
3698
3699 /* OPEN statement. */
3700
3701 void
3702 ffeste_R904 (ffestpOpenStmt *info)
3703 {
3704 ffeste_check_simple_ ();
3705
3706 #if FFECOM_targetCURRENT == FFECOM_targetFFE
3707 fputs ("+ OPEN (", dmpout);
3708 ffeste_subr_file_ ("UNIT", &info->open_spec[FFESTP_openixUNIT]);
3709 ffeste_subr_file_ ("ACCESS", &info->open_spec[FFESTP_openixACCESS]);
3710 ffeste_subr_file_ ("ACTION", &info->open_spec[FFESTP_openixACTION]);
3711 ffeste_subr_file_ ("ASSOCIATEVARIABLE", &info->open_spec[FFESTP_openixASSOCIATEVARIABLE]);
3712 ffeste_subr_file_ ("BLANK", &info->open_spec[FFESTP_openixBLANK]);
3713 ffeste_subr_file_ ("BLOCKSIZE", &info->open_spec[FFESTP_openixBLOCKSIZE]);
3714 ffeste_subr_file_ ("BUFFERCOUNT", &info->open_spec[FFESTP_openixBUFFERCOUNT]);
3715 ffeste_subr_file_ ("CARRIAGECONTROL", &info->open_spec[FFESTP_openixCARRIAGECONTROL]);
3716 ffeste_subr_file_ ("DEFAULTFILE", &info->open_spec[FFESTP_openixDEFAULTFILE]);
3717 ffeste_subr_file_ ("DELIM", &info->open_spec[FFESTP_openixDELIM]);
3718 ffeste_subr_file_ ("DISPOSE", &info->open_spec[FFESTP_openixDISPOSE]);
3719 ffeste_subr_file_ ("ERR", &info->open_spec[FFESTP_openixERR]);
3720 ffeste_subr_file_ ("EXTENDSIZE", &info->open_spec[FFESTP_openixEXTENDSIZE]);
3721 ffeste_subr_file_ ("FILE", &info->open_spec[FFESTP_openixFILE]);
3722 ffeste_subr_file_ ("FORM", &info->open_spec[FFESTP_openixFORM]);
3723 ffeste_subr_file_ ("INITIALSIZE", &info->open_spec[FFESTP_openixINITIALSIZE]);
3724 ffeste_subr_file_ ("IOSTAT", &info->open_spec[FFESTP_openixIOSTAT]);
3725 ffeste_subr_file_ ("KEY", &info->open_spec[FFESTP_openixKEY]);
3726 ffeste_subr_file_ ("MAXREC", &info->open_spec[FFESTP_openixMAXREC]);
3727 ffeste_subr_file_ ("NOSPANBLOCKS", &info->open_spec[FFESTP_openixNOSPANBLOCKS]);
3728 ffeste_subr_file_ ("ORGANIZATION", &info->open_spec[FFESTP_openixORGANIZATION]);
3729 ffeste_subr_file_ ("PAD", &info->open_spec[FFESTP_openixPAD]);
3730 ffeste_subr_file_ ("POSITION", &info->open_spec[FFESTP_openixPOSITION]);
3731 ffeste_subr_file_ ("READONLY", &info->open_spec[FFESTP_openixREADONLY]);
3732 ffeste_subr_file_ ("RECL", &info->open_spec[FFESTP_openixRECL]);
3733 ffeste_subr_file_ ("RECORDTYPE", &info->open_spec[FFESTP_openixRECORDTYPE]);
3734 ffeste_subr_file_ ("SHARED", &info->open_spec[FFESTP_openixSHARED]);
3735 ffeste_subr_file_ ("STATUS", &info->open_spec[FFESTP_openixSTATUS]);
3736 ffeste_subr_file_ ("USEROPEN", &info->open_spec[FFESTP_openixUSEROPEN]);
3737 fputs (")\n", dmpout);
3738 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
3739 {
3740 tree args;
3741 bool iostat;
3742 bool errl;
3743
3744 ffeste_emit_line_note_ ();
3745
3746 #define specified(something) (info->open_spec[something].kw_or_val_present)
3747
3748 iostat = specified (FFESTP_openixIOSTAT);
3749 errl = specified (FFESTP_openixERR);
3750
3751 #undef specified
3752
3753 ffeste_start_stmt_ ();
3754
3755 if (errl)
3756 {
3757 ffeste_io_err_
3758 = ffeste_io_abort_
3759 = ffecom_lookup_label
3760 (info->open_spec[FFESTP_openixERR].u.label);
3761 ffeste_io_abort_is_temp_ = FALSE;
3762 }
3763 else
3764 {
3765 ffeste_io_err_ = NULL_TREE;
3766
3767 if ((ffeste_io_abort_is_temp_ = iostat))
3768 ffeste_io_abort_ = ffecom_temp_label ();
3769 else
3770 ffeste_io_abort_ = NULL_TREE;
3771 }
3772
3773 if (iostat)
3774 {
3775 /* Have IOSTAT= specification. */
3776
3777 ffeste_io_iostat_is_temp_ = FALSE;
3778 ffeste_io_iostat_ = ffecom_expr
3779 (info->open_spec[FFESTP_openixIOSTAT].u.expr);
3780 }
3781 else if (ffeste_io_abort_ != NULL_TREE)
3782 {
3783 /* Have no IOSTAT= but have ERR=. */
3784
3785 ffeste_io_iostat_is_temp_ = TRUE;
3786 ffeste_io_iostat_
3787 = ffecom_make_tempvar ("open", ffecom_integer_type_node,
3788 FFETARGET_charactersizeNONE, -1);
3789 }
3790 else
3791 {
3792 /* No IOSTAT= or ERR= specification. */
3793
3794 ffeste_io_iostat_is_temp_ = FALSE;
3795 ffeste_io_iostat_ = NULL_TREE;
3796 }
3797
3798 /* Now prescan, then convert, all the arguments. */
3799
3800 args = ffeste_io_olist_ (errl || iostat,
3801 info->open_spec[FFESTP_openixUNIT].u.expr,
3802 &info->open_spec[FFESTP_openixFILE],
3803 &info->open_spec[FFESTP_openixSTATUS],
3804 &info->open_spec[FFESTP_openixACCESS],
3805 &info->open_spec[FFESTP_openixFORM],
3806 &info->open_spec[FFESTP_openixRECL],
3807 &info->open_spec[FFESTP_openixBLANK]);
3808
3809 /* Don't generate "if (iostat != 0) goto label;" if label is temp abort
3810 label, since we're gonna fall through to there anyway. */
3811
3812 ffeste_io_call_ (ffecom_call_gfrt (FFECOM_gfrtFOPEN, args, NULL_TREE),
3813 ! ffeste_io_abort_is_temp_);
3814
3815 /* If we've got a temp label, generate its code here. */
3816
3817 if (ffeste_io_abort_is_temp_)
3818 {
3819 DECL_INITIAL (ffeste_io_abort_) = error_mark_node;
3820 emit_nop ();
3821 expand_label (ffeste_io_abort_);
3822
3823 assert (ffeste_io_err_ == NULL_TREE);
3824 }
3825
3826 ffeste_end_stmt_ ();
3827 }
3828 #else
3829 #error
3830 #endif
3831 }
3832
3833 /* CLOSE statement. */
3834
3835 void
3836 ffeste_R907 (ffestpCloseStmt *info)
3837 {
3838 ffeste_check_simple_ ();
3839
3840 #if FFECOM_targetCURRENT == FFECOM_targetFFE
3841 fputs ("+ CLOSE (", dmpout);
3842 ffeste_subr_file_ ("UNIT", &info->close_spec[FFESTP_closeixUNIT]);
3843 ffeste_subr_file_ ("ERR", &info->close_spec[FFESTP_closeixERR]);
3844 ffeste_subr_file_ ("IOSTAT", &info->close_spec[FFESTP_closeixIOSTAT]);
3845 ffeste_subr_file_ ("STATUS", &info->close_spec[FFESTP_closeixSTATUS]);
3846 fputs (")\n", dmpout);
3847 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
3848 {
3849 tree args;
3850 bool iostat;
3851 bool errl;
3852
3853 ffeste_emit_line_note_ ();
3854
3855 #define specified(something) (info->close_spec[something].kw_or_val_present)
3856
3857 iostat = specified (FFESTP_closeixIOSTAT);
3858 errl = specified (FFESTP_closeixERR);
3859
3860 #undef specified
3861
3862 ffeste_start_stmt_ ();
3863
3864 if (errl)
3865 {
3866 ffeste_io_err_
3867 = ffeste_io_abort_
3868 = ffecom_lookup_label
3869 (info->close_spec[FFESTP_closeixERR].u.label);
3870 ffeste_io_abort_is_temp_ = FALSE;
3871 }
3872 else
3873 {
3874 ffeste_io_err_ = NULL_TREE;
3875
3876 if ((ffeste_io_abort_is_temp_ = iostat))
3877 ffeste_io_abort_ = ffecom_temp_label ();
3878 else
3879 ffeste_io_abort_ = NULL_TREE;
3880 }
3881
3882 if (iostat)
3883 {
3884 /* Have IOSTAT= specification. */
3885
3886 ffeste_io_iostat_is_temp_ = FALSE;
3887 ffeste_io_iostat_ = ffecom_expr
3888 (info->close_spec[FFESTP_closeixIOSTAT].u.expr);
3889 }
3890 else if (ffeste_io_abort_ != NULL_TREE)
3891 {
3892 /* Have no IOSTAT= but have ERR=. */
3893
3894 ffeste_io_iostat_is_temp_ = TRUE;
3895 ffeste_io_iostat_
3896 = ffecom_make_tempvar ("close", ffecom_integer_type_node,
3897 FFETARGET_charactersizeNONE, -1);
3898 }
3899 else
3900 {
3901 /* No IOSTAT= or ERR= specification. */
3902
3903 ffeste_io_iostat_is_temp_ = FALSE;
3904 ffeste_io_iostat_ = NULL_TREE;
3905 }
3906
3907 /* Now prescan, then convert, all the arguments. */
3908
3909 args = ffeste_io_cllist_ (errl || iostat,
3910 info->close_spec[FFESTP_closeixUNIT].u.expr,
3911 &info->close_spec[FFESTP_closeixSTATUS]);
3912
3913 /* Don't generate "if (iostat != 0) goto label;" if label is temp abort
3914 label, since we're gonna fall through to there anyway. */
3915
3916 ffeste_io_call_ (ffecom_call_gfrt (FFECOM_gfrtFCLOS, args, NULL_TREE),
3917 ! ffeste_io_abort_is_temp_);
3918
3919 /* If we've got a temp label, generate its code here. */
3920
3921 if (ffeste_io_abort_is_temp_)
3922 {
3923 DECL_INITIAL (ffeste_io_abort_) = error_mark_node;
3924 emit_nop ();
3925 expand_label (ffeste_io_abort_);
3926
3927 assert (ffeste_io_err_ == NULL_TREE);
3928 }
3929
3930 ffeste_end_stmt_ ();
3931 }
3932 #else
3933 #error
3934 #endif
3935 }
3936
3937 /* READ(...) statement -- start. */
3938
3939 void
3940 ffeste_R909_start (ffestpReadStmt *info, bool only_format UNUSED,
3941 ffestvUnit unit, ffestvFormat format, bool rec,
3942 bool key UNUSED)
3943 {
3944 ffeste_check_start_ ();
3945
3946 #if FFECOM_targetCURRENT == FFECOM_targetFFE
3947 switch (format)
3948 {
3949 case FFESTV_formatNONE:
3950 if (rec)
3951 fputs ("+ READ_ufdac", dmpout);
3952 else if (key)
3953 fputs ("+ READ_ufidx", dmpout);
3954 else
3955 fputs ("+ READ_ufseq", dmpout);
3956 break;
3957
3958 case FFESTV_formatLABEL:
3959 case FFESTV_formatCHAREXPR:
3960 case FFESTV_formatINTEXPR:
3961 if (rec)
3962 fputs ("+ READ_fmdac", dmpout);
3963 else if (key)
3964 fputs ("+ READ_fmidx", dmpout);
3965 else if (unit == FFESTV_unitCHAREXPR)
3966 fputs ("+ READ_fmint", dmpout);
3967 else
3968 fputs ("+ READ_fmseq", dmpout);
3969 break;
3970
3971 case FFESTV_formatASTERISK:
3972 if (unit == FFESTV_unitCHAREXPR)
3973 fputs ("+ READ_lsint", dmpout);
3974 else
3975 fputs ("+ READ_lsseq", dmpout);
3976 break;
3977
3978 case FFESTV_formatNAMELIST:
3979 fputs ("+ READ_nlseq", dmpout);
3980 break;
3981
3982 default:
3983 assert ("Unexpected kind of format item in R909 READ" == NULL);
3984 }
3985
3986 if (only_format)
3987 {
3988 fputc (' ', dmpout);
3989 ffeste_subr_file_ ("FORMAT", &info->read_spec[FFESTP_readixFORMAT]);
3990 fputc (' ', dmpout);
3991
3992 return;
3993 }
3994
3995 fputs (" (", dmpout);
3996 ffeste_subr_file_ ("UNIT", &info->read_spec[FFESTP_readixUNIT]);
3997 ffeste_subr_file_ ("FORMAT", &info->read_spec[FFESTP_readixFORMAT]);
3998 ffeste_subr_file_ ("ADVANCE", &info->read_spec[FFESTP_readixADVANCE]);
3999 ffeste_subr_file_ ("EOR", &info->read_spec[FFESTP_readixEOR]);
4000 ffeste_subr_file_ ("ERR", &info->read_spec[FFESTP_readixERR]);
4001 ffeste_subr_file_ ("END", &info->read_spec[FFESTP_readixEND]);
4002 ffeste_subr_file_ ("IOSTAT", &info->read_spec[FFESTP_readixIOSTAT]);
4003 ffeste_subr_file_ ("KEYEQ", &info->read_spec[FFESTP_readixKEYEQ]);
4004 ffeste_subr_file_ ("KEYGE", &info->read_spec[FFESTP_readixKEYGE]);
4005 ffeste_subr_file_ ("KEYGT", &info->read_spec[FFESTP_readixKEYGT]);
4006 ffeste_subr_file_ ("KEYID", &info->read_spec[FFESTP_readixKEYID]);
4007 ffeste_subr_file_ ("NULLS", &info->read_spec[FFESTP_readixNULLS]);
4008 ffeste_subr_file_ ("REC", &info->read_spec[FFESTP_readixREC]);
4009 ffeste_subr_file_ ("SIZE", &info->read_spec[FFESTP_readixSIZE]);
4010 fputs (") ", dmpout);
4011 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
4012
4013 ffeste_emit_line_note_ ();
4014
4015 {
4016 ffecomGfrt start;
4017 ffecomGfrt end;
4018 tree cilist;
4019 bool iostat;
4020 bool errl;
4021 bool endl;
4022
4023 /* First determine the start, per-item, and end run-time functions to
4024 call. The per-item function is picked by choosing an ffeste function
4025 to call to handle a given item; it knows how to generate a call to the
4026 appropriate run-time function, and is called an "I/O driver". */
4027
4028 switch (format)
4029 {
4030 case FFESTV_formatNONE: /* no FMT= */
4031 ffeste_io_driver_ = ffeste_io_douio_;
4032 if (rec)
4033 start = FFECOM_gfrtSRDUE, end = FFECOM_gfrtERDUE;
4034 #if 0
4035 else if (key)
4036 start = FFECOM_gfrtSRIUE, end = FFECOM_gfrtERIUE;
4037 #endif
4038 else
4039 start = FFECOM_gfrtSRSUE, end = FFECOM_gfrtERSUE;
4040 break;
4041
4042 case FFESTV_formatLABEL: /* FMT=10 */
4043 case FFESTV_formatCHAREXPR: /* FMT='(I10)' */
4044 case FFESTV_formatINTEXPR: /* FMT=I [after ASSIGN 10 TO I] */
4045 ffeste_io_driver_ = ffeste_io_dofio_;
4046 if (rec)
4047 start = FFECOM_gfrtSRDFE, end = FFECOM_gfrtERDFE;
4048 #if 0
4049 else if (key)
4050 start = FFECOM_gfrtSRIFE, end = FFECOM_gfrtERIFE;
4051 #endif
4052 else if (unit == FFESTV_unitCHAREXPR)
4053 start = FFECOM_gfrtSRSFI, end = FFECOM_gfrtERSFI;
4054 else
4055 start = FFECOM_gfrtSRSFE, end = FFECOM_gfrtERSFE;
4056 break;
4057
4058 case FFESTV_formatASTERISK: /* FMT=* */
4059 ffeste_io_driver_ = ffeste_io_dolio_;
4060 if (unit == FFESTV_unitCHAREXPR)
4061 start = FFECOM_gfrtSRSLI, end = FFECOM_gfrtERSLI;
4062 else
4063 start = FFECOM_gfrtSRSLE, end = FFECOM_gfrtERSLE;
4064 break;
4065
4066 case FFESTV_formatNAMELIST: /* FMT=FOO or NML=FOO [NAMELIST
4067 /FOO/] */
4068 ffeste_io_driver_ = NULL; /* No start or driver function. */
4069 start = FFECOM_gfrtSRSNE, end = FFECOM_gfrt;
4070 break;
4071
4072 default:
4073 assert ("Weird stuff" == NULL);
4074 start = FFECOM_gfrt, end = FFECOM_gfrt;
4075 break;
4076 }
4077 ffeste_io_endgfrt_ = end;
4078
4079 #define specified(something) (info->read_spec[something].kw_or_val_present)
4080
4081 iostat = specified (FFESTP_readixIOSTAT);
4082 errl = specified (FFESTP_readixERR);
4083 endl = specified (FFESTP_readixEND);
4084
4085 #undef specified
4086
4087 ffeste_start_stmt_ ();
4088
4089 if (errl)
4090 {
4091 /* Have ERR= specification. */
4092
4093 ffeste_io_err_
4094 = ffecom_lookup_label (info->read_spec[FFESTP_readixERR].u.label);
4095
4096 if (endl)
4097 {
4098 /* Have both ERR= and END=. Need a temp label to handle both. */
4099 ffeste_io_end_
4100 = ffecom_lookup_label (info->read_spec[FFESTP_readixEND].u.label);
4101 ffeste_io_abort_is_temp_ = TRUE;
4102 ffeste_io_abort_ = ffecom_temp_label ();
4103 }
4104 else
4105 {
4106 /* Have ERR= but no END=. */
4107 ffeste_io_end_ = NULL_TREE;
4108 if ((ffeste_io_abort_is_temp_ = iostat))
4109 ffeste_io_abort_ = ffecom_temp_label ();
4110 else
4111 ffeste_io_abort_ = ffeste_io_err_;
4112 }
4113 }
4114 else
4115 {
4116 /* No ERR= specification. */
4117
4118 ffeste_io_err_ = NULL_TREE;
4119 if (endl)
4120 {
4121 /* Have END= but no ERR=. */
4122 ffeste_io_end_
4123 = ffecom_lookup_label (info->read_spec[FFESTP_readixEND].u.label);
4124 if ((ffeste_io_abort_is_temp_ = iostat))
4125 ffeste_io_abort_ = ffecom_temp_label ();
4126 else
4127 ffeste_io_abort_ = ffeste_io_end_;
4128 }
4129 else
4130 {
4131 /* Have no ERR= or END=. */
4132
4133 ffeste_io_end_ = NULL_TREE;
4134 if ((ffeste_io_abort_is_temp_ = iostat))
4135 ffeste_io_abort_ = ffecom_temp_label ();
4136 else
4137 ffeste_io_abort_ = NULL_TREE;
4138 }
4139 }
4140
4141 if (iostat)
4142 {
4143 /* Have IOSTAT= specification. */
4144
4145 ffeste_io_iostat_is_temp_ = FALSE;
4146 ffeste_io_iostat_
4147 = ffecom_expr (info->read_spec[FFESTP_readixIOSTAT].u.expr);
4148 }
4149 else if (ffeste_io_abort_ != NULL_TREE)
4150 {
4151 /* Have no IOSTAT= but have ERR= and/or END=. */
4152
4153 ffeste_io_iostat_is_temp_ = TRUE;
4154 ffeste_io_iostat_
4155 = ffecom_make_tempvar ("read", ffecom_integer_type_node,
4156 FFETARGET_charactersizeNONE, -1);
4157 }
4158 else
4159 {
4160 /* No IOSTAT=, ERR=, or END= specification. */
4161
4162 ffeste_io_iostat_is_temp_ = FALSE;
4163 ffeste_io_iostat_ = NULL_TREE;
4164 }
4165
4166 /* Now prescan, then convert, all the arguments. */
4167
4168 if (unit == FFESTV_unitCHAREXPR)
4169 cilist = ffeste_io_icilist_ (errl || iostat,
4170 info->read_spec[FFESTP_readixUNIT].u.expr,
4171 endl || iostat, format,
4172 &info->read_spec[FFESTP_readixFORMAT]);
4173 else
4174 cilist = ffeste_io_cilist_ (errl || iostat, unit,
4175 info->read_spec[FFESTP_readixUNIT].u.expr,
4176 5, endl || iostat, format,
4177 &info->read_spec[FFESTP_readixFORMAT],
4178 rec,
4179 info->read_spec[FFESTP_readixREC].u.expr);
4180
4181 /* If there is no end function, then there are no item functions (i.e.
4182 it's a NAMELIST), and vice versa by the way. In this situation, don't
4183 generate the "if (iostat != 0) goto label;" if the label is temp abort
4184 label, since we're gonna fall through to there anyway. */
4185
4186 ffeste_io_call_ (ffecom_call_gfrt (start, cilist, NULL_TREE),
4187 (! ffeste_io_abort_is_temp_) || (end != FFECOM_gfrt));
4188 }
4189 #else
4190 #error
4191 #endif
4192 }
4193
4194 /* READ statement -- I/O item. */
4195
4196 void
4197 ffeste_R909_item (ffebld expr, ffelexToken expr_token)
4198 {
4199 ffeste_check_item_ ();
4200
4201 #if FFECOM_targetCURRENT == FFECOM_targetFFE
4202 ffebld_dump (expr);
4203 fputc (',', dmpout);
4204 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
4205 if (expr == NULL)
4206 return;
4207
4208 /* Strip parens off items such as in "READ *,(A)". This is really a bug
4209 in the user's code, but I've been told lots of code does this. */
4210 while (ffebld_op (expr) == FFEBLD_opPAREN)
4211 expr = ffebld_left (expr);
4212
4213 if (ffebld_op (expr) == FFEBLD_opANY)
4214 return;
4215
4216 if (ffebld_op (expr) == FFEBLD_opIMPDO)
4217 ffeste_io_impdo_ (expr, expr_token);
4218 else
4219 {
4220 ffeste_start_stmt_ ();
4221
4222 ffecom_prepare_arg_ptr_to_expr (expr);
4223
4224 ffecom_prepare_end ();
4225
4226 ffeste_io_call_ ((*ffeste_io_driver_) (expr), TRUE);
4227
4228 ffeste_end_stmt_ ();
4229 }
4230 #else
4231 #error
4232 #endif
4233 }
4234
4235 /* READ statement -- end. */
4236
4237 void
4238 ffeste_R909_finish ()
4239 {
4240 ffeste_check_finish_ ();
4241
4242 #if FFECOM_targetCURRENT == FFECOM_targetFFE
4243 fputc ('\n', dmpout);
4244 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
4245
4246 /* Don't generate "if (iostat != 0) goto label;" if label is temp abort
4247 label, since we're gonna fall through to there anyway. */
4248
4249 if (ffeste_io_endgfrt_ != FFECOM_gfrt)
4250 ffeste_io_call_ (ffecom_call_gfrt (ffeste_io_endgfrt_, NULL_TREE,
4251 NULL_TREE),
4252 ! ffeste_io_abort_is_temp_);
4253
4254 /* If we've got a temp label, generate its code here and have it fan out
4255 to the END= or ERR= label as appropriate. */
4256
4257 if (ffeste_io_abort_is_temp_)
4258 {
4259 DECL_INITIAL (ffeste_io_abort_) = error_mark_node;
4260 emit_nop ();
4261 expand_label (ffeste_io_abort_);
4262
4263 /* "if (iostat<0) goto end_label;". */
4264
4265 if ((ffeste_io_end_ != NULL_TREE)
4266 && (TREE_CODE (ffeste_io_end_) != ERROR_MARK))
4267 {
4268 expand_start_cond (ffecom_truth_value
4269 (ffecom_2 (LT_EXPR, integer_type_node,
4270 ffeste_io_iostat_,
4271 ffecom_integer_zero_node)),
4272 0);
4273 expand_goto (ffeste_io_end_);
4274 expand_end_cond ();
4275 }
4276
4277 /* "if (iostat>0) goto err_label;". */
4278
4279 if ((ffeste_io_err_ != NULL_TREE)
4280 && (TREE_CODE (ffeste_io_err_) != ERROR_MARK))
4281 {
4282 expand_start_cond (ffecom_truth_value
4283 (ffecom_2 (GT_EXPR, integer_type_node,
4284 ffeste_io_iostat_,
4285 ffecom_integer_zero_node)),
4286 0);
4287 expand_goto (ffeste_io_err_);
4288 expand_end_cond ();
4289 }
4290 }
4291
4292 ffeste_end_stmt_ ();
4293 #else
4294 #error
4295 #endif
4296 }
4297
4298 /* WRITE statement -- start. */
4299
4300 void
4301 ffeste_R910_start (ffestpWriteStmt *info, ffestvUnit unit,
4302 ffestvFormat format, bool rec)
4303 {
4304 ffeste_check_start_ ();
4305
4306 #if FFECOM_targetCURRENT == FFECOM_targetFFE
4307 switch (format)
4308 {
4309 case FFESTV_formatNONE:
4310 if (rec)
4311 fputs ("+ WRITE_ufdac (", dmpout);
4312 else
4313 fputs ("+ WRITE_ufseq_or_idx (", dmpout);
4314 break;
4315
4316 case FFESTV_formatLABEL:
4317 case FFESTV_formatCHAREXPR:
4318 case FFESTV_formatINTEXPR:
4319 if (rec)
4320 fputs ("+ WRITE_fmdac (", dmpout);
4321 else if (unit == FFESTV_unitCHAREXPR)
4322 fputs ("+ WRITE_fmint (", dmpout);
4323 else
4324 fputs ("+ WRITE_fmseq_or_idx (", dmpout);
4325 break;
4326
4327 case FFESTV_formatASTERISK:
4328 if (unit == FFESTV_unitCHAREXPR)
4329 fputs ("+ WRITE_lsint (", dmpout);
4330 else
4331 fputs ("+ WRITE_lsseq (", dmpout);
4332 break;
4333
4334 case FFESTV_formatNAMELIST:
4335 fputs ("+ WRITE_nlseq (", dmpout);
4336 break;
4337
4338 default:
4339 assert ("Unexpected kind of format item in R910 WRITE" == NULL);
4340 }
4341
4342 ffeste_subr_file_ ("UNIT", &info->write_spec[FFESTP_writeixUNIT]);
4343 ffeste_subr_file_ ("FORMAT", &info->write_spec[FFESTP_writeixFORMAT]);
4344 ffeste_subr_file_ ("ADVANCE", &info->write_spec[FFESTP_writeixADVANCE]);
4345 ffeste_subr_file_ ("EOR", &info->write_spec[FFESTP_writeixEOR]);
4346 ffeste_subr_file_ ("ERR", &info->write_spec[FFESTP_writeixERR]);
4347 ffeste_subr_file_ ("IOSTAT", &info->write_spec[FFESTP_writeixIOSTAT]);
4348 ffeste_subr_file_ ("REC", &info->write_spec[FFESTP_writeixREC]);
4349 fputs (") ", dmpout);
4350 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
4351
4352 ffeste_emit_line_note_ ();
4353
4354 {
4355 ffecomGfrt start;
4356 ffecomGfrt end;
4357 tree cilist;
4358 bool iostat;
4359 bool errl;
4360
4361 /* First determine the start, per-item, and end run-time functions to
4362 call. The per-item function is picked by choosing an ffeste function
4363 to call to handle a given item; it knows how to generate a call to the
4364 appropriate run-time function, and is called an "I/O driver". */
4365
4366 switch (format)
4367 {
4368 case FFESTV_formatNONE: /* no FMT= */
4369 ffeste_io_driver_ = ffeste_io_douio_;
4370 if (rec)
4371 start = FFECOM_gfrtSWDUE, end = FFECOM_gfrtEWDUE;
4372 else
4373 start = FFECOM_gfrtSWSUE, end = FFECOM_gfrtEWSUE;
4374 break;
4375
4376 case FFESTV_formatLABEL: /* FMT=10 */
4377 case FFESTV_formatCHAREXPR: /* FMT='(I10)' */
4378 case FFESTV_formatINTEXPR: /* FMT=I [after ASSIGN 10 TO I] */
4379 ffeste_io_driver_ = ffeste_io_dofio_;
4380 if (rec)
4381 start = FFECOM_gfrtSWDFE, end = FFECOM_gfrtEWDFE;
4382 else if (unit == FFESTV_unitCHAREXPR)
4383 start = FFECOM_gfrtSWSFI, end = FFECOM_gfrtEWSFI;
4384 else
4385 start = FFECOM_gfrtSWSFE, end = FFECOM_gfrtEWSFE;
4386 break;
4387
4388 case FFESTV_formatASTERISK: /* FMT=* */
4389 ffeste_io_driver_ = ffeste_io_dolio_;
4390 if (unit == FFESTV_unitCHAREXPR)
4391 start = FFECOM_gfrtSWSLI, end = FFECOM_gfrtEWSLI;
4392 else
4393 start = FFECOM_gfrtSWSLE, end = FFECOM_gfrtEWSLE;
4394 break;
4395
4396 case FFESTV_formatNAMELIST: /* FMT=FOO or NML=FOO [NAMELIST
4397 /FOO/] */
4398 ffeste_io_driver_ = NULL; /* No start or driver function. */
4399 start = FFECOM_gfrtSWSNE, end = FFECOM_gfrt;
4400 break;
4401
4402 default:
4403 assert ("Weird stuff" == NULL);
4404 start = FFECOM_gfrt, end = FFECOM_gfrt;
4405 break;
4406 }
4407 ffeste_io_endgfrt_ = end;
4408
4409 #define specified(something) (info->write_spec[something].kw_or_val_present)
4410
4411 iostat = specified (FFESTP_writeixIOSTAT);
4412 errl = specified (FFESTP_writeixERR);
4413
4414 #undef specified
4415
4416 ffeste_start_stmt_ ();
4417
4418 ffeste_io_end_ = NULL_TREE;
4419
4420 if (errl)
4421 {
4422 /* Have ERR= specification. */
4423
4424 ffeste_io_err_
4425 = ffeste_io_abort_
4426 = ffecom_lookup_label
4427 (info->write_spec[FFESTP_writeixERR].u.label);
4428 ffeste_io_abort_is_temp_ = FALSE;
4429 }
4430 else
4431 {
4432 /* No ERR= specification. */
4433
4434 ffeste_io_err_ = NULL_TREE;
4435
4436 if ((ffeste_io_abort_is_temp_ = iostat))
4437 ffeste_io_abort_ = ffecom_temp_label ();
4438 else
4439 ffeste_io_abort_ = NULL_TREE;
4440 }
4441
4442 if (iostat)
4443 {
4444 /* Have IOSTAT= specification. */
4445
4446 ffeste_io_iostat_is_temp_ = FALSE;
4447 ffeste_io_iostat_ = ffecom_expr
4448 (info->write_spec[FFESTP_writeixIOSTAT].u.expr);
4449 }
4450 else if (ffeste_io_abort_ != NULL_TREE)
4451 {
4452 /* Have no IOSTAT= but have ERR=. */
4453
4454 ffeste_io_iostat_is_temp_ = TRUE;
4455 ffeste_io_iostat_
4456 = ffecom_make_tempvar ("write", ffecom_integer_type_node,
4457 FFETARGET_charactersizeNONE, -1);
4458 }
4459 else
4460 {
4461 /* No IOSTAT= or ERR= specification. */
4462
4463 ffeste_io_iostat_is_temp_ = FALSE;
4464 ffeste_io_iostat_ = NULL_TREE;
4465 }
4466
4467 /* Now prescan, then convert, all the arguments. */
4468
4469 if (unit == FFESTV_unitCHAREXPR)
4470 cilist = ffeste_io_icilist_ (errl || iostat,
4471 info->write_spec[FFESTP_writeixUNIT].u.expr,
4472 FALSE, format,
4473 &info->write_spec[FFESTP_writeixFORMAT]);
4474 else
4475 cilist = ffeste_io_cilist_ (errl || iostat, unit,
4476 info->write_spec[FFESTP_writeixUNIT].u.expr,
4477 6, FALSE, format,
4478 &info->write_spec[FFESTP_writeixFORMAT],
4479 rec,
4480 info->write_spec[FFESTP_writeixREC].u.expr);
4481
4482 /* If there is no end function, then there are no item functions (i.e.
4483 it's a NAMELIST), and vice versa by the way. In this situation, don't
4484 generate the "if (iostat != 0) goto label;" if the label is temp abort
4485 label, since we're gonna fall through to there anyway. */
4486
4487 ffeste_io_call_ (ffecom_call_gfrt (start, cilist, NULL_TREE),
4488 (! ffeste_io_abort_is_temp_) || (end != FFECOM_gfrt));
4489 }
4490 #else
4491 #error
4492 #endif
4493 }
4494
4495 /* WRITE statement -- I/O item. */
4496
4497 void
4498 ffeste_R910_item (ffebld expr, ffelexToken expr_token)
4499 {
4500 ffeste_check_item_ ();
4501
4502 #if FFECOM_targetCURRENT == FFECOM_targetFFE
4503 ffebld_dump (expr);
4504 fputc (',', dmpout);
4505 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
4506 if (expr == NULL)
4507 return;
4508
4509 if (ffebld_op (expr) == FFEBLD_opANY)
4510 return;
4511
4512 if (ffebld_op (expr) == FFEBLD_opIMPDO)
4513 ffeste_io_impdo_ (expr, expr_token);
4514 else
4515 {
4516 ffeste_start_stmt_ ();
4517
4518 ffecom_prepare_arg_ptr_to_expr (expr);
4519
4520 ffecom_prepare_end ();
4521
4522 ffeste_io_call_ ((*ffeste_io_driver_) (expr), TRUE);
4523
4524 ffeste_end_stmt_ ();
4525 }
4526 #else
4527 #error
4528 #endif
4529 }
4530
4531 /* WRITE statement -- end. */
4532
4533 void
4534 ffeste_R910_finish ()
4535 {
4536 ffeste_check_finish_ ();
4537
4538 #if FFECOM_targetCURRENT == FFECOM_targetFFE
4539 fputc ('\n', dmpout);
4540 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
4541
4542 /* Don't generate "if (iostat != 0) goto label;" if label is temp abort
4543 label, since we're gonna fall through to there anyway. */
4544
4545 if (ffeste_io_endgfrt_ != FFECOM_gfrt)
4546 ffeste_io_call_ (ffecom_call_gfrt (ffeste_io_endgfrt_, NULL_TREE,
4547 NULL_TREE),
4548 ! ffeste_io_abort_is_temp_);
4549
4550 /* If we've got a temp label, generate its code here. */
4551
4552 if (ffeste_io_abort_is_temp_)
4553 {
4554 DECL_INITIAL (ffeste_io_abort_) = error_mark_node;
4555 emit_nop ();
4556 expand_label (ffeste_io_abort_);
4557
4558 assert (ffeste_io_err_ == NULL_TREE);
4559 }
4560
4561 ffeste_end_stmt_ ();
4562 #else
4563 #error
4564 #endif
4565 }
4566
4567 /* PRINT statement -- start. */
4568
4569 void
4570 ffeste_R911_start (ffestpPrintStmt *info, ffestvFormat format)
4571 {
4572 ffeste_check_start_ ();
4573
4574 #if FFECOM_targetCURRENT == FFECOM_targetFFE
4575 switch (format)
4576 {
4577 case FFESTV_formatLABEL:
4578 case FFESTV_formatCHAREXPR:
4579 case FFESTV_formatINTEXPR:
4580 fputs ("+ PRINT_fm ", dmpout);
4581 break;
4582
4583 case FFESTV_formatASTERISK:
4584 fputs ("+ PRINT_ls ", dmpout);
4585 break;
4586
4587 case FFESTV_formatNAMELIST:
4588 fputs ("+ PRINT_nl ", dmpout);
4589 break;
4590
4591 default:
4592 assert ("Unexpected kind of format item in R911 PRINT" == NULL);
4593 }
4594 ffeste_subr_file_ ("FORMAT", &info->print_spec[FFESTP_printixFORMAT]);
4595 fputc (' ', dmpout);
4596 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
4597
4598 ffeste_emit_line_note_ ();
4599
4600 {
4601 ffecomGfrt start;
4602 ffecomGfrt end;
4603 tree cilist;
4604
4605 /* First determine the start, per-item, and end run-time functions to
4606 call. The per-item function is picked by choosing an ffeste function
4607 to call to handle a given item; it knows how to generate a call to the
4608 appropriate run-time function, and is called an "I/O driver". */
4609
4610 switch (format)
4611 {
4612 case FFESTV_formatLABEL: /* FMT=10 */
4613 case FFESTV_formatCHAREXPR: /* FMT='(I10)' */
4614 case FFESTV_formatINTEXPR: /* FMT=I [after ASSIGN 10 TO I] */
4615 ffeste_io_driver_ = ffeste_io_dofio_;
4616 start = FFECOM_gfrtSWSFE, end = FFECOM_gfrtEWSFE;
4617 break;
4618
4619 case FFESTV_formatASTERISK: /* FMT=* */
4620 ffeste_io_driver_ = ffeste_io_dolio_;
4621 start = FFECOM_gfrtSWSLE, end = FFECOM_gfrtEWSLE;
4622 break;
4623
4624 case FFESTV_formatNAMELIST: /* FMT=FOO or NML=FOO [NAMELIST
4625 /FOO/] */
4626 ffeste_io_driver_ = NULL; /* No start or driver function. */
4627 start = FFECOM_gfrtSWSNE, end = FFECOM_gfrt;
4628 break;
4629
4630 default:
4631 assert ("Weird stuff" == NULL);
4632 start = FFECOM_gfrt, end = FFECOM_gfrt;
4633 break;
4634 }
4635 ffeste_io_endgfrt_ = end;
4636
4637 ffeste_start_stmt_ ();
4638
4639 ffeste_io_end_ = NULL_TREE;
4640 ffeste_io_err_ = NULL_TREE;
4641 ffeste_io_abort_ = NULL_TREE;
4642 ffeste_io_abort_is_temp_ = FALSE;
4643 ffeste_io_iostat_is_temp_ = FALSE;
4644 ffeste_io_iostat_ = NULL_TREE;
4645
4646 /* Now prescan, then convert, all the arguments. */
4647
4648 cilist = ffeste_io_cilist_ (FALSE, FFESTV_unitNONE, NULL, 6, FALSE, format,
4649 &info->print_spec[FFESTP_printixFORMAT], FALSE, NULL);
4650
4651 /* If there is no end function, then there are no item functions (i.e.
4652 it's a NAMELIST), and vice versa by the way. In this situation, don't
4653 generate the "if (iostat != 0) goto label;" if the label is temp abort
4654 label, since we're gonna fall through to there anyway. */
4655
4656 ffeste_io_call_ (ffecom_call_gfrt (start, cilist, NULL_TREE),
4657 (! ffeste_io_abort_is_temp_) || (end != FFECOM_gfrt));
4658 }
4659 #else
4660 #error
4661 #endif
4662 }
4663
4664 /* PRINT statement -- I/O item. */
4665
4666 void
4667 ffeste_R911_item (ffebld expr, ffelexToken expr_token)
4668 {
4669 ffeste_check_item_ ();
4670
4671 #if FFECOM_targetCURRENT == FFECOM_targetFFE
4672 ffebld_dump (expr);
4673 fputc (',', dmpout);
4674 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
4675 if (expr == NULL)
4676 return;
4677
4678 if (ffebld_op (expr) == FFEBLD_opANY)
4679 return;
4680
4681 if (ffebld_op (expr) == FFEBLD_opIMPDO)
4682 ffeste_io_impdo_ (expr, expr_token);
4683 else
4684 {
4685 ffeste_start_stmt_ ();
4686
4687 ffecom_prepare_arg_ptr_to_expr (expr);
4688
4689 ffecom_prepare_end ();
4690
4691 ffeste_io_call_ ((*ffeste_io_driver_) (expr), TRUE);
4692
4693 ffeste_end_stmt_ ();
4694 }
4695 #else
4696 #error
4697 #endif
4698 }
4699
4700 /* PRINT statement -- end. */
4701
4702 void
4703 ffeste_R911_finish ()
4704 {
4705 ffeste_check_finish_ ();
4706
4707 #if FFECOM_targetCURRENT == FFECOM_targetFFE
4708 fputc ('\n', dmpout);
4709 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
4710
4711 if (ffeste_io_endgfrt_ != FFECOM_gfrt)
4712 ffeste_io_call_ (ffecom_call_gfrt (ffeste_io_endgfrt_, NULL_TREE,
4713 NULL_TREE),
4714 FALSE);
4715
4716 ffeste_end_stmt_ ();
4717 #else
4718 #error
4719 #endif
4720 }
4721
4722 /* BACKSPACE statement. */
4723
4724 void
4725 ffeste_R919 (ffestpBeruStmt *info)
4726 {
4727 ffeste_check_simple_ ();
4728
4729 #if FFECOM_targetCURRENT == FFECOM_targetFFE
4730 fputs ("+ BACKSPACE (", dmpout);
4731 ffeste_subr_file_ ("UNIT", &info->beru_spec[FFESTP_beruixUNIT]);
4732 ffeste_subr_file_ ("ERR", &info->beru_spec[FFESTP_beruixERR]);
4733 ffeste_subr_file_ ("IOSTAT", &info->beru_spec[FFESTP_beruixIOSTAT]);
4734 fputs (")\n", dmpout);
4735 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
4736 ffeste_subr_beru_ (info, FFECOM_gfrtFBACK);
4737 #else
4738 #error
4739 #endif
4740 }
4741
4742 /* ENDFILE statement. */
4743
4744 void
4745 ffeste_R920 (ffestpBeruStmt *info)
4746 {
4747 ffeste_check_simple_ ();
4748
4749 #if FFECOM_targetCURRENT == FFECOM_targetFFE
4750 fputs ("+ ENDFILE (", dmpout);
4751 ffeste_subr_file_ ("UNIT", &info->beru_spec[FFESTP_beruixUNIT]);
4752 ffeste_subr_file_ ("ERR", &info->beru_spec[FFESTP_beruixERR]);
4753 ffeste_subr_file_ ("IOSTAT", &info->beru_spec[FFESTP_beruixIOSTAT]);
4754 fputs (")\n", dmpout);
4755 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
4756 ffeste_subr_beru_ (info, FFECOM_gfrtFEND);
4757 #else
4758 #error
4759 #endif
4760 }
4761
4762 /* REWIND statement. */
4763
4764 void
4765 ffeste_R921 (ffestpBeruStmt *info)
4766 {
4767 ffeste_check_simple_ ();
4768
4769 #if FFECOM_targetCURRENT == FFECOM_targetFFE
4770 fputs ("+ REWIND (", dmpout);
4771 ffeste_subr_file_ ("UNIT", &info->beru_spec[FFESTP_beruixUNIT]);
4772 ffeste_subr_file_ ("ERR", &info->beru_spec[FFESTP_beruixERR]);
4773 ffeste_subr_file_ ("IOSTAT", &info->beru_spec[FFESTP_beruixIOSTAT]);
4774 fputs (")\n", dmpout);
4775 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
4776 ffeste_subr_beru_ (info, FFECOM_gfrtFREW);
4777 #else
4778 #error
4779 #endif
4780 }
4781
4782 /* INQUIRE statement (non-IOLENGTH version). */
4783
4784 void
4785 ffeste_R923A (ffestpInquireStmt *info, bool by_file UNUSED)
4786 {
4787 ffeste_check_simple_ ();
4788
4789 #if FFECOM_targetCURRENT == FFECOM_targetFFE
4790 if (by_file)
4791 {
4792 fputs ("+ INQUIRE_file (", dmpout);
4793 ffeste_subr_file_ ("FILE", &info->inquire_spec[FFESTP_inquireixFILE]);
4794 }
4795 else
4796 {
4797 fputs ("+ INQUIRE_unit (", dmpout);
4798 ffeste_subr_file_ ("UNIT", &info->inquire_spec[FFESTP_inquireixUNIT]);
4799 }
4800 ffeste_subr_file_ ("ACCESS", &info->inquire_spec[FFESTP_inquireixACCESS]);
4801 ffeste_subr_file_ ("ACTION", &info->inquire_spec[FFESTP_inquireixACTION]);
4802 ffeste_subr_file_ ("BLANK", &info->inquire_spec[FFESTP_inquireixBLANK]);
4803 ffeste_subr_file_ ("CARRIAGECONTROL", &info->inquire_spec[FFESTP_inquireixCARRIAGECONTROL]);
4804 ffeste_subr_file_ ("DEFAULTFILE", &info->inquire_spec[FFESTP_inquireixDEFAULTFILE]);
4805 ffeste_subr_file_ ("DELIM", &info->inquire_spec[FFESTP_inquireixDELIM]);
4806 ffeste_subr_file_ ("DIRECT", &info->inquire_spec[FFESTP_inquireixDIRECT]);
4807 ffeste_subr_file_ ("ERR", &info->inquire_spec[FFESTP_inquireixERR]);
4808 ffeste_subr_file_ ("EXIST", &info->inquire_spec[FFESTP_inquireixEXIST]);
4809 ffeste_subr_file_ ("FORM", &info->inquire_spec[FFESTP_inquireixFORM]);
4810 ffeste_subr_file_ ("FORMATTED", &info->inquire_spec[FFESTP_inquireixFORMATTED]);
4811 ffeste_subr_file_ ("IOSTAT", &info->inquire_spec[FFESTP_inquireixIOSTAT]);
4812 ffeste_subr_file_ ("KEYED", &info->inquire_spec[FFESTP_inquireixKEYED]);
4813 ffeste_subr_file_ ("NAME", &info->inquire_spec[FFESTP_inquireixNAME]);
4814 ffeste_subr_file_ ("NAMED", &info->inquire_spec[FFESTP_inquireixNAMED]);
4815 ffeste_subr_file_ ("NEXTREC", &info->inquire_spec[FFESTP_inquireixNEXTREC]);
4816 ffeste_subr_file_ ("NUMBER", &info->inquire_spec[FFESTP_inquireixNUMBER]);
4817 ffeste_subr_file_ ("OPENED", &info->inquire_spec[FFESTP_inquireixOPENED]);
4818 ffeste_subr_file_ ("ORGANIZATION", &info->inquire_spec[FFESTP_inquireixORGANIZATION]);
4819 ffeste_subr_file_ ("PAD", &info->inquire_spec[FFESTP_inquireixPAD]);
4820 ffeste_subr_file_ ("POSITION", &info->inquire_spec[FFESTP_inquireixPOSITION]);
4821 ffeste_subr_file_ ("READ", &info->inquire_spec[FFESTP_inquireixREAD]);
4822 ffeste_subr_file_ ("READWRITE", &info->inquire_spec[FFESTP_inquireixREADWRITE]);
4823 ffeste_subr_file_ ("RECL", &info->inquire_spec[FFESTP_inquireixRECL]);
4824 ffeste_subr_file_ ("RECORDTYPE", &info->inquire_spec[FFESTP_inquireixRECORDTYPE]);
4825 ffeste_subr_file_ ("SEQUENTIAL", &info->inquire_spec[FFESTP_inquireixSEQUENTIAL]);
4826 ffeste_subr_file_ ("UNFORMATTED", &info->inquire_spec[FFESTP_inquireixUNFORMATTED]);
4827 ffeste_subr_file_ ("WRITE", &info->inquire_spec[FFESTP_inquireixWRITE]);
4828 fputs (")\n", dmpout);
4829 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
4830 {
4831 tree args;
4832 bool iostat;
4833 bool errl;
4834
4835 ffeste_emit_line_note_ ();
4836
4837 #define specified(something) (info->inquire_spec[something].kw_or_val_present)
4838
4839 iostat = specified (FFESTP_inquireixIOSTAT);
4840 errl = specified (FFESTP_inquireixERR);
4841
4842 #undef specified
4843
4844 ffeste_start_stmt_ ();
4845
4846 if (errl)
4847 {
4848 ffeste_io_err_
4849 = ffeste_io_abort_
4850 = ffecom_lookup_label
4851 (info->inquire_spec[FFESTP_inquireixERR].u.label);
4852 ffeste_io_abort_is_temp_ = FALSE;
4853 }
4854 else
4855 {
4856 ffeste_io_err_ = NULL_TREE;
4857
4858 if ((ffeste_io_abort_is_temp_ = iostat))
4859 ffeste_io_abort_ = ffecom_temp_label ();
4860 else
4861 ffeste_io_abort_ = NULL_TREE;
4862 }
4863
4864 if (iostat)
4865 {
4866 /* Have IOSTAT= specification. */
4867
4868 ffeste_io_iostat_is_temp_ = FALSE;
4869 ffeste_io_iostat_ = ffecom_expr
4870 (info->inquire_spec[FFESTP_inquireixIOSTAT].u.expr);
4871 }
4872 else if (ffeste_io_abort_ != NULL_TREE)
4873 {
4874 /* Have no IOSTAT= but have ERR=. */
4875
4876 ffeste_io_iostat_is_temp_ = TRUE;
4877 ffeste_io_iostat_
4878 = ffecom_make_tempvar ("inquire", ffecom_integer_type_node,
4879 FFETARGET_charactersizeNONE, -1);
4880 }
4881 else
4882 {
4883 /* No IOSTAT= or ERR= specification. */
4884
4885 ffeste_io_iostat_is_temp_ = FALSE;
4886 ffeste_io_iostat_ = NULL_TREE;
4887 }
4888
4889 /* Now prescan, then convert, all the arguments. */
4890
4891 args
4892 = ffeste_io_inlist_ (errl || iostat,
4893 &info->inquire_spec[FFESTP_inquireixUNIT],
4894 &info->inquire_spec[FFESTP_inquireixFILE],
4895 &info->inquire_spec[FFESTP_inquireixEXIST],
4896 &info->inquire_spec[FFESTP_inquireixOPENED],
4897 &info->inquire_spec[FFESTP_inquireixNUMBER],
4898 &info->inquire_spec[FFESTP_inquireixNAMED],
4899 &info->inquire_spec[FFESTP_inquireixNAME],
4900 &info->inquire_spec[FFESTP_inquireixACCESS],
4901 &info->inquire_spec[FFESTP_inquireixSEQUENTIAL],
4902 &info->inquire_spec[FFESTP_inquireixDIRECT],
4903 &info->inquire_spec[FFESTP_inquireixFORM],
4904 &info->inquire_spec[FFESTP_inquireixFORMATTED],
4905 &info->inquire_spec[FFESTP_inquireixUNFORMATTED],
4906 &info->inquire_spec[FFESTP_inquireixRECL],
4907 &info->inquire_spec[FFESTP_inquireixNEXTREC],
4908 &info->inquire_spec[FFESTP_inquireixBLANK]);
4909
4910 /* Don't generate "if (iostat != 0) goto label;" if label is temp abort
4911 label, since we're gonna fall through to there anyway. */
4912
4913 ffeste_io_call_ (ffecom_call_gfrt (FFECOM_gfrtFINQU, args, NULL_TREE),
4914 ! ffeste_io_abort_is_temp_);
4915
4916 /* If we've got a temp label, generate its code here. */
4917
4918 if (ffeste_io_abort_is_temp_)
4919 {
4920 DECL_INITIAL (ffeste_io_abort_) = error_mark_node;
4921 emit_nop ();
4922 expand_label (ffeste_io_abort_);
4923
4924 assert (ffeste_io_err_ == NULL_TREE);
4925 }
4926
4927 ffeste_end_stmt_ ();
4928 }
4929 #else
4930 #error
4931 #endif
4932 }
4933
4934 /* INQUIRE(IOLENGTH=expr) statement -- start. */
4935
4936 void
4937 ffeste_R923B_start (ffestpInquireStmt *info UNUSED)
4938 {
4939 ffeste_check_start_ ();
4940
4941 #if FFECOM_targetCURRENT == FFECOM_targetFFE
4942 fputs ("+ INQUIRE (", dmpout);
4943 ffeste_subr_file_ ("IOLENGTH", &info->inquire_spec[FFESTP_inquireixIOLENGTH]);
4944 fputs (") ", dmpout);
4945 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
4946 assert ("INQUIRE(IOLENGTH=<var>) not implemented yet! ~~~" == NULL);
4947
4948 ffeste_emit_line_note_ ();
4949 #else
4950 #error
4951 #endif
4952 }
4953
4954 /* INQUIRE(IOLENGTH=expr) statement -- I/O item. */
4955
4956 void
4957 ffeste_R923B_item (ffebld expr UNUSED)
4958 {
4959 ffeste_check_item_ ();
4960
4961 #if FFECOM_targetCURRENT == FFECOM_targetFFE
4962 ffebld_dump (expr);
4963 fputc (',', dmpout);
4964 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
4965 #else
4966 #error
4967 #endif
4968 }
4969
4970 /* INQUIRE(IOLENGTH=expr) statement -- end. */
4971
4972 void
4973 ffeste_R923B_finish ()
4974 {
4975 ffeste_check_finish_ ();
4976
4977 #if FFECOM_targetCURRENT == FFECOM_targetFFE
4978 fputc ('\n', dmpout);
4979 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
4980 #else
4981 #error
4982 #endif
4983 }
4984
4985 /* ffeste_R1001 -- FORMAT statement
4986
4987 ffeste_R1001(format_list); */
4988
4989 void
4990 ffeste_R1001 (ffests s)
4991 {
4992 ffeste_check_simple_ ();
4993
4994 #if FFECOM_targetCURRENT == FFECOM_targetFFE
4995 fprintf (dmpout, "$ FORMAT %.*s\n", (int) ffests_length (s), ffests_text (s));
4996 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
4997 {
4998 tree t;
4999 tree ttype;
5000 tree maxindex;
5001 tree var;
5002
5003 assert (ffeste_label_formatdef_ != NULL);
5004
5005 ffeste_emit_line_note_ ();
5006
5007 t = build_string (ffests_length (s), ffests_text (s));
5008
5009 TREE_TYPE (t)
5010 = build_type_variant (build_array_type
5011 (char_type_node,
5012 build_range_type (integer_type_node,
5013 integer_one_node,
5014 build_int_2 (ffests_length (s),
5015 0))),
5016 1, 0);
5017 TREE_CONSTANT (t) = 1;
5018 TREE_STATIC (t) = 1;
5019
5020 push_obstacks_nochange ();
5021 end_temporary_allocation ();
5022
5023 var = ffecom_lookup_label (ffeste_label_formatdef_);
5024 if ((var != NULL_TREE)
5025 && (TREE_CODE (var) == VAR_DECL))
5026 {
5027 DECL_INITIAL (var) = t;
5028 maxindex = build_int_2 (ffests_length (s) - 1, 0);
5029 ttype = TREE_TYPE (var);
5030 TYPE_DOMAIN (ttype) = build_range_type (integer_type_node,
5031 integer_zero_node,
5032 maxindex);
5033 if (!TREE_TYPE (maxindex))
5034 TREE_TYPE (maxindex) = TYPE_DOMAIN (ttype);
5035 layout_type (ttype);
5036 rest_of_decl_compilation (var, NULL, 1, 0);
5037 expand_decl (var);
5038 expand_decl_init (var);
5039 }
5040
5041 resume_temporary_allocation ();
5042 pop_obstacks ();
5043
5044 ffeste_label_formatdef_ = NULL;
5045 }
5046 #else
5047 #error
5048 #endif
5049 }
5050
5051 /* END PROGRAM. */
5052
5053 void
5054 ffeste_R1103 ()
5055 {
5056 #if FFECOM_targetCURRENT == FFECOM_targetFFE
5057 fputs ("+ END_PROGRAM\n", dmpout);
5058 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
5059 #else
5060 #error
5061 #endif
5062 }
5063
5064 /* END BLOCK DATA. */
5065
5066 void
5067 ffeste_R1112 ()
5068 {
5069 #if FFECOM_targetCURRENT == FFECOM_targetFFE
5070 fputs ("* END_BLOCK_DATA\n", dmpout);
5071 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
5072 #else
5073 #error
5074 #endif
5075 }
5076
5077 /* CALL statement. */
5078
5079 void
5080 ffeste_R1212 (ffebld expr)
5081 {
5082 ffeste_check_simple_ ();
5083
5084 #if FFECOM_targetCURRENT == FFECOM_targetFFE
5085 fputs ("+ CALL ", dmpout);
5086 ffebld_dump (expr);
5087 fputc ('\n', dmpout);
5088 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
5089 {
5090 ffebld args = ffebld_right (expr);
5091 ffebld arg;
5092 ffebld labels = NULL; /* First in list of LABTERs. */
5093 ffebld prevlabels = NULL;
5094 ffebld prevargs = NULL;
5095
5096 ffeste_emit_line_note_ ();
5097
5098 /* Here we split the list at ffebld_right(expr) into two lists: one at
5099 ffebld_right(expr) consisting of all items that are not LABTERs, the
5100 other at labels consisting of all items that are LABTERs. Then, if
5101 the latter list is NULL, we have an ordinary call, else we have a call
5102 with alternate returns. */
5103
5104 for (args = ffebld_right (expr); args != NULL; args = ffebld_trail (args))
5105 {
5106 if (((arg = ffebld_head (args)) == NULL)
5107 || (ffebld_op (arg) != FFEBLD_opLABTER))
5108 {
5109 if (prevargs == NULL)
5110 {
5111 prevargs = args;
5112 ffebld_set_right (expr, args);
5113 }
5114 else
5115 {
5116 ffebld_set_trail (prevargs, args);
5117 prevargs = args;
5118 }
5119 }
5120 else
5121 {
5122 if (prevlabels == NULL)
5123 {
5124 prevlabels = labels = args;
5125 }
5126 else
5127 {
5128 ffebld_set_trail (prevlabels, args);
5129 prevlabels = args;
5130 }
5131 }
5132 }
5133 if (prevlabels == NULL)
5134 labels = NULL;
5135 else
5136 ffebld_set_trail (prevlabels, NULL);
5137 if (prevargs == NULL)
5138 ffebld_set_right (expr, NULL);
5139 else
5140 ffebld_set_trail (prevargs, NULL);
5141
5142 ffeste_start_stmt_ ();
5143
5144 /* No temporaries are actually needed at this level, but we go
5145 through the motions anyway, just to be sure in case they do
5146 get made. Temporaries needed for arguments should be in the
5147 scopes of inner blocks, and if clean-up actions are supported,
5148 such as CALL-ing an intrinsic that writes to an argument of one
5149 type when a variable of a different type is provided (requiring
5150 assignment to the variable from a temporary after the library
5151 routine returns), the clean-up must be done by the expression
5152 evaluator, generally, to handle alternate returns (which we hope
5153 won't ever be supported by intrinsics, but might be a similar
5154 issue, such as CALL-ing an F90-style subroutine with an INTERFACE
5155 block). That implies the expression evaluator will have to
5156 recognize the need for its own temporary anyway, meaning it'll
5157 construct a block within the one constructed here. */
5158
5159 ffecom_prepare_expr (expr);
5160
5161 ffecom_prepare_end ();
5162
5163 if (labels == NULL)
5164 expand_expr_stmt (ffecom_expr (expr));
5165 else
5166 {
5167 tree texpr;
5168 tree value;
5169 tree tlabel;
5170 int caseno;
5171 int pushok;
5172 tree duplicate;
5173 ffebld label;
5174
5175 texpr = ffecom_expr (expr);
5176 expand_start_case (0, texpr, TREE_TYPE (texpr), "CALL statement");
5177
5178 for (caseno = 1, label = labels;
5179 label != NULL;
5180 ++caseno, label = ffebld_trail (label))
5181 {
5182 value = build_int_2 (caseno, 0);
5183 tlabel = build_decl (LABEL_DECL, NULL_TREE, NULL_TREE);
5184
5185 pushok = pushcase (value, convert, tlabel, &duplicate);
5186 assert (pushok == 0);
5187
5188 tlabel
5189 = ffecom_lookup_label (ffebld_labter (ffebld_head (label)));
5190 if ((tlabel == NULL_TREE)
5191 || (TREE_CODE (tlabel) == ERROR_MARK))
5192 continue;
5193 TREE_USED (tlabel) = 1;
5194 expand_goto (tlabel);
5195 }
5196
5197 expand_end_case (texpr);
5198 }
5199
5200 ffeste_end_stmt_ ();
5201 }
5202 #else
5203 #error
5204 #endif
5205 }
5206
5207 /* END FUNCTION. */
5208
5209 void
5210 ffeste_R1221 ()
5211 {
5212 #if FFECOM_targetCURRENT == FFECOM_targetFFE
5213 fputs ("+ END_FUNCTION\n", dmpout);
5214 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
5215 #else
5216 #error
5217 #endif
5218 }
5219
5220 /* END SUBROUTINE. */
5221
5222 void
5223 ffeste_R1225 ()
5224 {
5225 #if FFECOM_targetCURRENT == FFECOM_targetFFE
5226 fprintf (dmpout, "+ END_SUBROUTINE\n");
5227 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
5228 #else
5229 #error
5230 #endif
5231 }
5232
5233 /* ENTRY statement. */
5234
5235 void
5236 ffeste_R1226 (ffesymbol entry)
5237 {
5238 ffeste_check_simple_ ();
5239
5240 #if FFECOM_targetCURRENT == FFECOM_targetFFE
5241 fprintf (dmpout, "+ ENTRY %s", ffesymbol_text (entry));
5242 if (ffesymbol_dummyargs (entry) != NULL)
5243 {
5244 ffebld argh;
5245
5246 fputc ('(', dmpout);
5247 for (argh = ffesymbol_dummyargs (entry);
5248 argh != NULL;
5249 argh = ffebld_trail (argh))
5250 {
5251 assert (ffebld_head (argh) != NULL);
5252 switch (ffebld_op (ffebld_head (argh)))
5253 {
5254 case FFEBLD_opSYMTER:
5255 fputs (ffesymbol_text (ffebld_symter (ffebld_head (argh))),
5256 dmpout);
5257 break;
5258
5259 case FFEBLD_opSTAR:
5260 fputc ('*', dmpout);
5261 break;
5262
5263 default:
5264 fputc ('?', dmpout);
5265 ffebld_dump (ffebld_head (argh));
5266 fputc ('?', dmpout);
5267 break;
5268 }
5269 if (ffebld_trail (argh) != NULL)
5270 fputc (',', dmpout);
5271 }
5272 fputc (')', dmpout);
5273 }
5274 fputc ('\n', dmpout);
5275 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
5276 {
5277 tree label = ffesymbol_hook (entry).length_tree;
5278
5279 ffeste_emit_line_note_ ();
5280
5281 if (label == error_mark_node)
5282 return;
5283
5284 DECL_INITIAL (label) = error_mark_node;
5285 emit_nop ();
5286 expand_label (label);
5287 }
5288 #else
5289 #error
5290 #endif
5291 }
5292
5293 /* RETURN statement. */
5294
5295 void
5296 ffeste_R1227 (ffestw block UNUSED, ffebld expr)
5297 {
5298 ffeste_check_simple_ ();
5299
5300 #if FFECOM_targetCURRENT == FFECOM_targetFFE
5301 if (expr == NULL)
5302 {
5303 fputs ("+ RETURN\n", dmpout);
5304 }
5305 else
5306 {
5307 fputs ("+ RETURN_alternate ", dmpout);
5308 ffebld_dump (expr);
5309 fputc ('\n', dmpout);
5310 }
5311 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
5312 {
5313 tree rtn;
5314
5315 ffeste_emit_line_note_ ();
5316
5317 ffeste_start_stmt_ ();
5318
5319 ffecom_prepare_return_expr (expr);
5320
5321 ffecom_prepare_end ();
5322
5323 rtn = ffecom_return_expr (expr);
5324
5325 if ((rtn == NULL_TREE)
5326 || (rtn == error_mark_node))
5327 expand_null_return ();
5328 else
5329 {
5330 tree result = DECL_RESULT (current_function_decl);
5331
5332 if ((result != error_mark_node)
5333 && (TREE_TYPE (result) != error_mark_node))
5334 expand_return (ffecom_modify (NULL_TREE,
5335 result,
5336 convert (TREE_TYPE (result),
5337 rtn)));
5338 else
5339 expand_null_return ();
5340 }
5341
5342 ffeste_end_stmt_ ();
5343 }
5344 #else
5345 #error
5346 #endif
5347 }
5348
5349 /* REWRITE statement -- start. */
5350
5351 #if FFESTR_VXT
5352 void
5353 ffeste_V018_start (ffestpRewriteStmt *info, ffestvFormat format)
5354 {
5355 ffeste_check_start_ ();
5356
5357 #if FFECOM_targetCURRENT == FFECOM_targetFFE
5358 switch (format)
5359 {
5360 case FFESTV_formatNONE:
5361 fputs ("+ REWRITE_uf (", dmpout);
5362 break;
5363
5364 case FFESTV_formatLABEL:
5365 case FFESTV_formatCHAREXPR:
5366 case FFESTV_formatINTEXPR:
5367 fputs ("+ REWRITE_fm (", dmpout);
5368 break;
5369
5370 default:
5371 assert ("Unexpected kind of format item in V018 REWRITE" == NULL);
5372 }
5373 ffeste_subr_file_ ("UNIT", &info->rewrite_spec[FFESTP_rewriteixUNIT]);
5374 ffeste_subr_file_ ("FMT", &info->rewrite_spec[FFESTP_rewriteixFMT]);
5375 ffeste_subr_file_ ("ERR", &info->rewrite_spec[FFESTP_rewriteixERR]);
5376 ffeste_subr_file_ ("IOSTAT", &info->rewrite_spec[FFESTP_rewriteixIOSTAT]);
5377 fputs (") ", dmpout);
5378 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
5379 #else
5380 #error
5381 #endif
5382 }
5383
5384 /* REWRITE statement -- I/O item. */
5385
5386 void
5387 ffeste_V018_item (ffebld expr)
5388 {
5389 ffeste_check_item_ ();
5390
5391 #if FFECOM_targetCURRENT == FFECOM_targetFFE
5392 ffebld_dump (expr);
5393 fputc (',', dmpout);
5394 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
5395 #else
5396 #error
5397 #endif
5398 }
5399
5400 /* REWRITE statement -- end. */
5401
5402 void
5403 ffeste_V018_finish ()
5404 {
5405 ffeste_check_finish_ ();
5406
5407 #if FFECOM_targetCURRENT == FFECOM_targetFFE
5408 fputc ('\n', dmpout);
5409 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
5410 #else
5411 #error
5412 #endif
5413 }
5414
5415 /* ACCEPT statement -- start. */
5416
5417 void
5418 ffeste_V019_start (ffestpAcceptStmt *info, ffestvFormat format)
5419 {
5420 ffeste_check_start_ ();
5421
5422 #if FFECOM_targetCURRENT == FFECOM_targetFFE
5423 switch (format)
5424 {
5425 case FFESTV_formatLABEL:
5426 case FFESTV_formatCHAREXPR:
5427 case FFESTV_formatINTEXPR:
5428 fputs ("+ ACCEPT_fm ", dmpout);
5429 break;
5430
5431 case FFESTV_formatASTERISK:
5432 fputs ("+ ACCEPT_ls ", dmpout);
5433 break;
5434
5435 case FFESTV_formatNAMELIST:
5436 fputs ("+ ACCEPT_nl ", dmpout);
5437 break;
5438
5439 default:
5440 assert ("Unexpected kind of format item in V019 ACCEPT" == NULL);
5441 }
5442 ffeste_subr_file_ ("FORMAT", &info->accept_spec[FFESTP_acceptixFORMAT]);
5443 fputc (' ', dmpout);
5444 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
5445 #else
5446 #error
5447 #endif
5448 }
5449
5450 /* ACCEPT statement -- I/O item. */
5451
5452 void
5453 ffeste_V019_item (ffebld expr)
5454 {
5455 ffeste_check_item_ ();
5456
5457 #if FFECOM_targetCURRENT == FFECOM_targetFFE
5458 ffebld_dump (expr);
5459 fputc (',', dmpout);
5460 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
5461 #else
5462 #error
5463 #endif
5464 }
5465
5466 /* ACCEPT statement -- end. */
5467
5468 void
5469 ffeste_V019_finish ()
5470 {
5471 ffeste_check_finish_ ();
5472
5473 #if FFECOM_targetCURRENT == FFECOM_targetFFE
5474 fputc ('\n', dmpout);
5475 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
5476 #else
5477 #error
5478 #endif
5479 }
5480
5481 #endif
5482 /* TYPE statement -- start. */
5483
5484 void
5485 ffeste_V020_start (ffestpTypeStmt *info UNUSED,
5486 ffestvFormat format UNUSED)
5487 {
5488 ffeste_check_start_ ();
5489
5490 #if FFECOM_targetCURRENT == FFECOM_targetFFE
5491 switch (format)
5492 {
5493 case FFESTV_formatLABEL:
5494 case FFESTV_formatCHAREXPR:
5495 case FFESTV_formatINTEXPR:
5496 fputs ("+ TYPE_fm ", dmpout);
5497 break;
5498
5499 case FFESTV_formatASTERISK:
5500 fputs ("+ TYPE_ls ", dmpout);
5501 break;
5502
5503 case FFESTV_formatNAMELIST:
5504 fputs ("* TYPE_nl ", dmpout);
5505 break;
5506
5507 default:
5508 assert ("Unexpected kind of format item in V020 TYPE" == NULL);
5509 }
5510 ffeste_subr_file_ ("FORMAT", &info->type_spec[FFESTP_typeixFORMAT]);
5511 fputc (' ', dmpout);
5512 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
5513 #else
5514 #error
5515 #endif
5516 }
5517
5518 /* TYPE statement -- I/O item. */
5519
5520 void
5521 ffeste_V020_item (ffebld expr UNUSED)
5522 {
5523 ffeste_check_item_ ();
5524
5525 #if FFECOM_targetCURRENT == FFECOM_targetFFE
5526 ffebld_dump (expr);
5527 fputc (',', dmpout);
5528 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
5529 #else
5530 #error
5531 #endif
5532 }
5533
5534 /* TYPE statement -- end. */
5535
5536 void
5537 ffeste_V020_finish ()
5538 {
5539 ffeste_check_finish_ ();
5540
5541 #if FFECOM_targetCURRENT == FFECOM_targetFFE
5542 fputc ('\n', dmpout);
5543 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
5544 #else
5545 #error
5546 #endif
5547 }
5548
5549 /* DELETE statement. */
5550
5551 #if FFESTR_VXT
5552 void
5553 ffeste_V021 (ffestpDeleteStmt *info)
5554 {
5555 ffeste_check_simple_ ();
5556
5557 #if FFECOM_targetCURRENT == FFECOM_targetFFE
5558 fputs ("+ DELETE (", dmpout);
5559 ffeste_subr_file_ ("UNIT", &info->delete_spec[FFESTP_deleteixUNIT]);
5560 ffeste_subr_file_ ("REC", &info->delete_spec[FFESTP_deleteixREC]);
5561 ffeste_subr_file_ ("ERR", &info->delete_spec[FFESTP_deleteixERR]);
5562 ffeste_subr_file_ ("IOSTAT", &info->delete_spec[FFESTP_deleteixIOSTAT]);
5563 fputs (")\n", dmpout);
5564 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
5565 #else
5566 #error
5567 #endif
5568 }
5569
5570 /* UNLOCK statement. */
5571
5572 void
5573 ffeste_V022 (ffestpBeruStmt *info)
5574 {
5575 ffeste_check_simple_ ();
5576
5577 #if FFECOM_targetCURRENT == FFECOM_targetFFE
5578 fputs ("+ UNLOCK (", dmpout);
5579 ffeste_subr_file_ ("UNIT", &info->beru_spec[FFESTP_beruixUNIT]);
5580 ffeste_subr_file_ ("ERR", &info->beru_spec[FFESTP_beruixERR]);
5581 ffeste_subr_file_ ("IOSTAT", &info->beru_spec[FFESTP_beruixIOSTAT]);
5582 fputs (")\n", dmpout);
5583 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
5584 #else
5585 #error
5586 #endif
5587 }
5588
5589 /* ENCODE statement -- start. */
5590
5591 void
5592 ffeste_V023_start (ffestpVxtcodeStmt *info)
5593 {
5594 ffeste_check_start_ ();
5595
5596 #if FFECOM_targetCURRENT == FFECOM_targetFFE
5597 fputs ("+ ENCODE (", dmpout);
5598 ffeste_subr_file_ ("C", &info->vxtcode_spec[FFESTP_vxtcodeixC]);
5599 ffeste_subr_file_ ("F", &info->vxtcode_spec[FFESTP_vxtcodeixF]);
5600 ffeste_subr_file_ ("B", &info->vxtcode_spec[FFESTP_vxtcodeixB]);
5601 ffeste_subr_file_ ("ERR", &info->vxtcode_spec[FFESTP_vxtcodeixERR]);
5602 ffeste_subr_file_ ("IOSTAT", &info->vxtcode_spec[FFESTP_vxtcodeixIOSTAT]);
5603 fputs (") ", dmpout);
5604 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
5605 #else
5606 #error
5607 #endif
5608 }
5609
5610 /* ENCODE statement -- I/O item. */
5611
5612 void
5613 ffeste_V023_item (ffebld expr)
5614 {
5615 ffeste_check_item_ ();
5616
5617 #if FFECOM_targetCURRENT == FFECOM_targetFFE
5618 ffebld_dump (expr);
5619 fputc (',', dmpout);
5620 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
5621 #else
5622 #error
5623 #endif
5624 }
5625
5626 /* ENCODE statement -- end. */
5627
5628 void
5629 ffeste_V023_finish ()
5630 {
5631 ffeste_check_finish_ ();
5632
5633 #if FFECOM_targetCURRENT == FFECOM_targetFFE
5634 fputc ('\n', dmpout);
5635 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
5636 #else
5637 #error
5638 #endif
5639 }
5640
5641 /* DECODE statement -- start. */
5642
5643 void
5644 ffeste_V024_start (ffestpVxtcodeStmt *info)
5645 {
5646 ffeste_check_start_ ();
5647
5648 #if FFECOM_targetCURRENT == FFECOM_targetFFE
5649 fputs ("+ DECODE (", dmpout);
5650 ffeste_subr_file_ ("C", &info->vxtcode_spec[FFESTP_vxtcodeixC]);
5651 ffeste_subr_file_ ("F", &info->vxtcode_spec[FFESTP_vxtcodeixF]);
5652 ffeste_subr_file_ ("B", &info->vxtcode_spec[FFESTP_vxtcodeixB]);
5653 ffeste_subr_file_ ("ERR", &info->vxtcode_spec[FFESTP_vxtcodeixERR]);
5654 ffeste_subr_file_ ("IOSTAT", &info->vxtcode_spec[FFESTP_vxtcodeixIOSTAT]);
5655 fputs (") ", dmpout);
5656 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
5657 #else
5658 #error
5659 #endif
5660 }
5661
5662 /* DECODE statement -- I/O item. */
5663
5664 void
5665 ffeste_V024_item (ffebld expr)
5666 {
5667 ffeste_check_item_ ();
5668
5669 #if FFECOM_targetCURRENT == FFECOM_targetFFE
5670 ffebld_dump (expr);
5671 fputc (',', dmpout);
5672 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
5673 #else
5674 #error
5675 #endif
5676 }
5677
5678 /* DECODE statement -- end. */
5679
5680 void
5681 ffeste_V024_finish ()
5682 {
5683 ffeste_check_finish_ ();
5684
5685 #if FFECOM_targetCURRENT == FFECOM_targetFFE
5686 fputc ('\n', dmpout);
5687 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
5688 #else
5689 #error
5690 #endif
5691 }
5692
5693 /* DEFINEFILE statement -- start. */
5694
5695 void
5696 ffeste_V025_start ()
5697 {
5698 ffeste_check_start_ ();
5699
5700 #if FFECOM_targetCURRENT == FFECOM_targetFFE
5701 fputs ("+ DEFINE_FILE ", dmpout);
5702 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
5703 #else
5704 #error
5705 #endif
5706 }
5707
5708 /* DEFINE FILE statement -- item. */
5709
5710 void
5711 ffeste_V025_item (ffebld u, ffebld m, ffebld n, ffebld asv)
5712 {
5713 ffeste_check_item_ ();
5714
5715 #if FFECOM_targetCURRENT == FFECOM_targetFFE
5716 ffebld_dump (u);
5717 fputc ('(', dmpout);
5718 ffebld_dump (m);
5719 fputc (',', dmpout);
5720 ffebld_dump (n);
5721 fputs (",U,", dmpout);
5722 ffebld_dump (asv);
5723 fputs ("),", dmpout);
5724 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
5725 #else
5726 #error
5727 #endif
5728 }
5729
5730 /* DEFINE FILE statement -- end. */
5731
5732 void
5733 ffeste_V025_finish ()
5734 {
5735 ffeste_check_finish_ ();
5736
5737 #if FFECOM_targetCURRENT == FFECOM_targetFFE
5738 fputc ('\n', dmpout);
5739 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
5740 #else
5741 #error
5742 #endif
5743 }
5744
5745 /* FIND statement. */
5746
5747 void
5748 ffeste_V026 (ffestpFindStmt *info)
5749 {
5750 ffeste_check_simple_ ();
5751
5752 #if FFECOM_targetCURRENT == FFECOM_targetFFE
5753 fputs ("+ FIND (", dmpout);
5754 ffeste_subr_file_ ("UNIT", &info->find_spec[FFESTP_findixUNIT]);
5755 ffeste_subr_file_ ("REC", &info->find_spec[FFESTP_findixREC]);
5756 ffeste_subr_file_ ("ERR", &info->find_spec[FFESTP_findixERR]);
5757 ffeste_subr_file_ ("IOSTAT", &info->find_spec[FFESTP_findixIOSTAT]);
5758 fputs (")\n", dmpout);
5759 #elif FFECOM_targetCURRENT == FFECOM_targetGCC
5760 #else
5761 #error
5762 #endif
5763 }
5764
5765 #endif
5766
5767 #ifdef ENABLE_CHECKING
5768 void
5769 ffeste_terminate_2 (void)
5770 {
5771 assert (! ffeste_top_block_);
5772 }
5773 #endif
Mirror of the offical gcc git repository hosted at gcc.gnu.org