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