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