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