+2001-10-17 Richard Henderson <rth@redhat.com>
+
+ * com.h: Remove FFECOM_targetCURRENT, FFECOM_ONEPASS, BUILT_FOR_270,
+ BUILT_FOR_280, FFECOM_GCC_INCLUDE, all derivitive defines, and all
+ related conditional compilation directives.
+ * bad.c, bld.c, bld.h, com.c, equiv.c, equiv.h, global.h, intdoc.c,
+ intrin.c, intrin.h, lex.c, parse.c, sta.c, std.c, ste.c, ste.h, stt.c,
+ stt.h, stw.h, symbol.c, symbol.h, target.h, top.c: Likewise.
+
2001-10-17 Richard Henderson <rth@redhat.com>
* Make-lang.in (f/com.o): Depend on langhooks.h.
ffebad_message_ = message;
}
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
- {
- switch (ffebad_severity_)
- { /* Tell toplev.c about this message. */
- case FFEBAD_severityINFORMATIONAL:
- case FFEBAD_severityTRIVIAL:
- if (inhibit_warnings)
- { /* User wants no warnings. */
- ffebad_is_temp_inhibited_ = TRUE;
- return FALSE;
- }
- /* Fall through. */
- case FFEBAD_severityWARNING:
- case FFEBAD_severityPECULIAR:
- case FFEBAD_severityPEDANTIC:
- if ((ffebad_severity_ != FFEBAD_severityPEDANTIC)
- || !flag_pedantic_errors)
- {
- if (count_error (1) == 0)
- { /* User wants no warnings. */
- ffebad_is_temp_inhibited_ = TRUE;
- return FALSE;
- }
- break;
- }
- /* Fall through (PEDANTIC && flag_pedantic_errors). */
- case FFEBAD_severityFATAL:
- case FFEBAD_severityWEIRD:
- case FFEBAD_severitySEVERE:
- case FFEBAD_severityDISASTER:
- count_error (0);
- break;
+ switch (ffebad_severity_)
+ { /* Tell toplev.c about this message. */
+ case FFEBAD_severityINFORMATIONAL:
+ case FFEBAD_severityTRIVIAL:
+ if (inhibit_warnings)
+ { /* User wants no warnings. */
+ ffebad_is_temp_inhibited_ = TRUE;
+ return FALSE;
+ }
+ /* Fall through. */
+ case FFEBAD_severityWARNING:
+ case FFEBAD_severityPECULIAR:
+ case FFEBAD_severityPEDANTIC:
+ if ((ffebad_severity_ != FFEBAD_severityPEDANTIC)
+ || !flag_pedantic_errors)
+ {
+ if (count_error (1) == 0)
+ { /* User wants no warnings. */
+ ffebad_is_temp_inhibited_ = TRUE;
+ return FALSE;
+ }
+ break;
+ }
+ /* Fall through (PEDANTIC && flag_pedantic_errors). */
+ case FFEBAD_severityFATAL:
+ case FFEBAD_severityWEIRD:
+ case FFEBAD_severitySEVERE:
+ case FFEBAD_severityDISASTER:
+ count_error (0);
+ break;
- default:
- break;
- }
- }
-#endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
+ default:
+ break;
+ }
ffebad_is_temp_inhibited_ = FALSE;
ffebad_errnum_ = errnum;
{
if (bi != 0)
fputc ('\n', stderr);
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
report_error_function (fn);
-#endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
fprintf (stderr,
-#if 0
- "Line %" ffewhereLineNumber_f "u of %s:\n %s\n %s%c",
- rn, fn,
-#else
/* the trailing space on the <file>:<line>: line
fools emacs19 compilation mode into finding the
report */
"%s:%" ffewhereLineNumber_f "u: %s\n %s\n %s%c",
fn, rn,
-#endif
s,
ffewhere_line_content (l),
&spaces[cn > MAX_SPACES ? 0 : MAX_SPACES - cn + 4],
}
}
-/* ffebld_constant_dump -- Display summary of constant's contents
-
- ffebldConstant c;
- ffebld_constant_dump(c);
-
- Displays the constant in summary form. */
-
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
-void
-ffebld_constant_dump (ffebldConstant c)
-{
- switch (ffebld_constant_type (c))
- {
-#if FFETARGET_okINTEGER1
- case FFEBLD_constINTEGER1:
- ffebld_dump_prefix (dmpout, FFEINFO_basictypeINTEGER,
- FFEINFO_kindtypeINTEGER1);
- ffebld_constantunion_dump (ffebld_constant_union (c),
- FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER1);
- break;
-#endif
-
-#if FFETARGET_okINTEGER2
- case FFEBLD_constINTEGER2:
- ffebld_dump_prefix (dmpout, FFEINFO_basictypeINTEGER,
- FFEINFO_kindtypeINTEGER2);
- ffebld_constantunion_dump (ffebld_constant_union (c),
- FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER2);
- break;
-#endif
-
-#if FFETARGET_okINTEGER3
- case FFEBLD_constINTEGER3:
- ffebld_dump_prefix (dmpout, FFEINFO_basictypeINTEGER,
- FFEINFO_kindtypeINTEGER3);
- ffebld_constantunion_dump (ffebld_constant_union (c),
- FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER3);
- break;
-#endif
-
-#if FFETARGET_okINTEGER4
- case FFEBLD_constINTEGER4:
- ffebld_dump_prefix (dmpout, FFEINFO_basictypeINTEGER,
- FFEINFO_kindtypeINTEGER4);
- ffebld_constantunion_dump (ffebld_constant_union (c),
- FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER4);
- break;
-#endif
-
-#if FFETARGET_okINTEGER5
- case FFEBLD_constINTEGER5:
- ffebld_dump_prefix (dmpout, FFEINFO_basictypeINTEGER,
- FFEINFO_kindtypeINTEGER5);
- ffebld_constantunion_dump (ffebld_constant_union (c),
- FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER5);
- break;
-#endif
-
-#if FFETARGET_okINTEGER6
- case FFEBLD_constINTEGER6:
- ffebld_dump_prefix (dmpout, FFEINFO_basictypeINTEGER,
- FFEINFO_kindtypeINTEGER6);
- ffebld_constantunion_dump (ffebld_constant_union (c),
- FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER6);
- break;
-#endif
-
-#if FFETARGET_okINTEGER7
- case FFEBLD_constINTEGER7:
- ffebld_dump_prefix (dmpout, FFEINFO_basictypeINTEGER,
- FFEINFO_kindtypeINTEGER7);
- ffebld_constantunion_dump (ffebld_constant_union (c),
- FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER7);
- break;
-#endif
-
-#if FFETARGET_okINTEGER8
- case FFEBLD_constINTEGER8:
- ffebld_dump_prefix (dmpout, FFEINFO_basictypeINTEGER,
- FFEINFO_kindtypeINTEGER8);
- ffebld_constantunion_dump (ffebld_constant_union (c),
- FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER8);
- break;
-#endif
-
-#if FFETARGET_okLOGICAL1
- case FFEBLD_constLOGICAL1:
- ffebld_dump_prefix (dmpout, FFEINFO_basictypeLOGICAL,
- FFEINFO_kindtypeLOGICAL1);
- ffebld_constantunion_dump (ffebld_constant_union (c),
- FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL1);
- break;
-#endif
-
-#if FFETARGET_okLOGICAL2
- case FFEBLD_constLOGICAL2:
- ffebld_dump_prefix (dmpout, FFEINFO_basictypeLOGICAL,
- FFEINFO_kindtypeLOGICAL2);
- ffebld_constantunion_dump (ffebld_constant_union (c),
- FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL2);
- break;
-#endif
-
-#if FFETARGET_okLOGICAL3
- case FFEBLD_constLOGICAL3:
- ffebld_dump_prefix (dmpout, FFEINFO_basictypeLOGICAL,
- FFEINFO_kindtypeLOGICAL3);
- ffebld_constantunion_dump (ffebld_constant_union (c),
- FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL3);
- break;
-#endif
-
-#if FFETARGET_okLOGICAL4
- case FFEBLD_constLOGICAL4:
- ffebld_dump_prefix (dmpout, FFEINFO_basictypeLOGICAL,
- FFEINFO_kindtypeLOGICAL4);
- ffebld_constantunion_dump (ffebld_constant_union (c),
- FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL4);
- break;
-#endif
-
-#if FFETARGET_okLOGICAL5
- case FFEBLD_constLOGICAL5:
- ffebld_dump_prefix (dmpout, FFEINFO_basictypeLOGICAL,
- FFEINFO_kindtypeLOGICAL5);
- ffebld_constantunion_dump (ffebld_constant_union (c),
- FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL5);
- break;
-#endif
-
-#if FFETARGET_okLOGICAL6
- case FFEBLD_constLOGICAL6:
- ffebld_dump_prefix (dmpout, FFEINFO_basictypeLOGICAL,
- FFEINFO_kindtypeLOGICAL6);
- ffebld_constantunion_dump (ffebld_constant_union (c),
- FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL6);
- break;
-#endif
-
-#if FFETARGET_okLOGICAL7
- case FFEBLD_constLOGICAL7:
- ffebld_dump_prefix (dmpout, FFEINFO_basictypeLOGICAL,
- FFEINFO_kindtypeLOGICAL7);
- ffebld_constantunion_dump (ffebld_constant_union (c),
- FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL7);
- break;
-#endif
-
-#if FFETARGET_okLOGICAL8
- case FFEBLD_constLOGICAL8:
- ffebld_dump_prefix (dmpout, FFEINFO_basictypeLOGICAL,
- FFEINFO_kindtypeLOGICAL8);
- ffebld_constantunion_dump (ffebld_constant_union (c),
- FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL8);
- break;
-#endif
-
-#if FFETARGET_okREAL1
- case FFEBLD_constREAL1:
- ffebld_dump_prefix (dmpout, FFEINFO_basictypeREAL,
- FFEINFO_kindtypeREAL1);
- ffebld_constantunion_dump (ffebld_constant_union (c),
- FFEINFO_basictypeREAL, FFEINFO_kindtypeREAL1);
- break;
-#endif
-
-#if FFETARGET_okREAL2
- case FFEBLD_constREAL2:
- ffebld_dump_prefix (dmpout, FFEINFO_basictypeREAL,
- FFEINFO_kindtypeREAL2);
- ffebld_constantunion_dump (ffebld_constant_union (c),
- FFEINFO_basictypeREAL, FFEINFO_kindtypeREAL2);
- break;
-#endif
-
-#if FFETARGET_okREAL3
- case FFEBLD_constREAL3:
- ffebld_dump_prefix (dmpout, FFEINFO_basictypeREAL,
- FFEINFO_kindtypeREAL3);
- ffebld_constantunion_dump (ffebld_constant_union (c),
- FFEINFO_basictypeREAL, FFEINFO_kindtypeREAL3);
- break;
-#endif
-
-#if FFETARGET_okREAL4
- case FFEBLD_constREAL4:
- ffebld_dump_prefix (dmpout, FFEINFO_basictypeREAL,
- FFEINFO_kindtypeREAL4);
- ffebld_constantunion_dump (ffebld_constant_union (c),
- FFEINFO_basictypeREAL, FFEINFO_kindtypeREAL4);
- break;
-#endif
-
-#if FFETARGET_okREAL5
- case FFEBLD_constREAL5:
- ffebld_dump_prefix (dmpout, FFEINFO_basictypeREAL,
- FFEINFO_kindtypeREAL5);
- ffebld_constantunion_dump (ffebld_constant_union (c),
- FFEINFO_basictypeREAL, FFEINFO_kindtypeREAL5);
- break;
-#endif
-
-#if FFETARGET_okREAL6
- case FFEBLD_constREAL6:
- ffebld_dump_prefix (dmpout, FFEINFO_basictypeREAL,
- FFEINFO_kindtypeREAL6);
- ffebld_constantunion_dump (ffebld_constant_union (c),
- FFEINFO_basictypeREAL, FFEINFO_kindtypeREAL6);
- break;
-#endif
-
-#if FFETARGET_okREAL7
- case FFEBLD_constREAL7:
- ffebld_dump_prefix (dmpout, FFEINFO_basictypeREAL,
- FFEINFO_kindtypeREAL7);
- ffebld_constantunion_dump (ffebld_constant_union (c),
- FFEINFO_basictypeREAL, FFEINFO_kindtypeREAL7);
- break;
-#endif
-
-#if FFETARGET_okREAL8
- case FFEBLD_constREAL8:
- ffebld_dump_prefix (dmpout, FFEINFO_basictypeREAL,
- FFEINFO_kindtypeREAL8);
- ffebld_constantunion_dump (ffebld_constant_union (c),
- FFEINFO_basictypeREAL, FFEINFO_kindtypeREAL8);
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX1
- case FFEBLD_constCOMPLEX1:
- ffebld_dump_prefix (dmpout, FFEINFO_basictypeCOMPLEX,
- FFEINFO_kindtypeREAL1);
- ffebld_constantunion_dump (ffebld_constant_union (c),
- FFEINFO_basictypeCOMPLEX, FFEINFO_kindtypeREAL1);
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX2
- case FFEBLD_constCOMPLEX2:
- ffebld_dump_prefix (dmpout, FFEINFO_basictypeCOMPLEX,
- FFEINFO_kindtypeREAL2);
- ffebld_constantunion_dump (ffebld_constant_union (c),
- FFEINFO_basictypeCOMPLEX, FFEINFO_kindtypeREAL2);
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX3
- case FFEBLD_constCOMPLEX3:
- ffebld_dump_prefix (dmpout, FFEINFO_basictypeCOMPLEX,
- FFEINFO_kindtypeREAL3);
- ffebld_constantunion_dump (ffebld_constant_union (c),
- FFEINFO_basictypeCOMPLEX, FFEINFO_kindtypeREAL3);
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX4
- case FFEBLD_constCOMPLEX4:
- ffebld_dump_prefix (dmpout, FFEINFO_basictypeCOMPLEX,
- FFEINFO_kindtypeREAL4);
- ffebld_constantunion_dump (ffebld_constant_union (c),
- FFEINFO_basictypeCOMPLEX, FFEINFO_kindtypeREAL4);
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX5
- case FFEBLD_constCOMPLEX5:
- ffebld_dump_prefix (dmpout, FFEINFO_basictypeCOMPLEX,
- FFEINFO_kindtypeREAL5);
- ffebld_constantunion_dump (ffebld_constant_union (c),
- FFEINFO_basictypeCOMPLEX, FFEINFO_kindtypeREAL5);
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX6
- case FFEBLD_constCOMPLEX6:
- ffebld_dump_prefix (dmpout, FFEINFO_basictypeCOMPLEX,
- FFEINFO_kindtypeREAL6);
- ffebld_constantunion_dump (ffebld_constant_union (c),
- FFEINFO_basictypeCOMPLEX, FFEINFO_kindtypeREAL6);
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX7
- case FFEBLD_constCOMPLEX7:
- ffebld_dump_prefix (dmpout, FFEINFO_basictypeCOMPLEX,
- FFEINFO_kindtypeREAL7);
- ffebld_constantunion_dump (ffebld_constant_union (c),
- FFEINFO_basictypeCOMPLEX, FFEINFO_kindtypeREAL7);
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX8
- case FFEBLD_constCOMPLEX8:
- ffebld_dump_prefix (dmpout, FFEINFO_basictypeCOMPLEX,
- FFEINFO_kindtypeREAL8);
- ffebld_constantunion_dump (ffebld_constant_union (c),
- FFEINFO_basictypeCOMPLEX, FFEINFO_kindtypeREAL8);
- break;
-#endif
-
-#if FFETARGET_okCHARACTER1
- case FFEBLD_constCHARACTER1:
- ffebld_dump_prefix (dmpout, FFEINFO_basictypeCHARACTER,
- FFEINFO_kindtypeCHARACTER1);
- ffebld_constantunion_dump (ffebld_constant_union (c),
- FFEINFO_basictypeCHARACTER, FFEINFO_kindtypeCHARACTER1);
- break;
-#endif
-
-#if FFETARGET_okCHARACTER2
- case FFEBLD_constCHARACTER2:
- ffebld_dump_prefix (dmpout, FFEINFO_basictypeCHARACTER,
- FFEINFO_kindtypeCHARACTER2);
- ffebld_constantunion_dump (ffebld_constant_union (c),
- FFEINFO_basictypeCHARACTER, FFEINFO_kindtypeCHARACTER2);
- break;
-#endif
-
-#if FFETARGET_okCHARACTER3
- case FFEBLD_constCHARACTER3:
- ffebld_dump_prefix (dmpout, FFEINFO_basictypeCHARACTER,
- FFEINFO_kindtypeCHARACTER3);
- ffebld_constantunion_dump (ffebld_constant_union (c),
- FFEINFO_basictypeCHARACTER, FFEINFO_kindtypeCHARACTER3);
- break;
-#endif
-
-#if FFETARGET_okCHARACTER4
- case FFEBLD_constCHARACTER4:
- ffebld_dump_prefix (dmpout, FFEINFO_basictypeCHARACTER,
- FFEINFO_kindtypeCHARACTER4);
- ffebld_constantunion_dump (ffebld_constant_union (c),
- FFEINFO_basictypeCHARACTER, FFEINFO_kindtypeCHARACTER4);
- break;
-#endif
-
-#if FFETARGET_okCHARACTER5
- case FFEBLD_constCHARACTER5:
- ffebld_dump_prefix (dmpout, FFEINFO_basictypeCHARACTER,
- FFEINFO_kindtypeCHARACTER5);
- ffebld_constantunion_dump (ffebld_constant_union (c),
- FFEINFO_basictypeCHARACTER, FFEINFO_kindtypeCHARACTER5);
- break;
-#endif
-
-#if FFETARGET_okCHARACTER6
- case FFEBLD_constCHARACTER6:
- ffebld_dump_prefix (dmpout, FFEINFO_basictypeCHARACTER,
- FFEINFO_kindtypeCHARACTER6);
- ffebld_constantunion_dump (ffebld_constant_union (c),
- FFEINFO_basictypeCHARACTER, FFEINFO_kindtypeCHARACTER6);
- break;
-#endif
-
-#if FFETARGET_okCHARACTER7
- case FFEBLD_constCHARACTER7:
- ffebld_dump_prefix (dmpout, FFEINFO_basictypeCHARACTER,
- FFEINFO_kindtypeCHARACTER7);
- ffebld_constantunion_dump (ffebld_constant_union (c),
- FFEINFO_basictypeCHARACTER, FFEINFO_kindtypeCHARACTER7);
- break;
-#endif
-
-#if FFETARGET_okCHARACTER8
- case FFEBLD_constCHARACTER8:
- ffebld_dump_prefix (dmpout, FFEINFO_basictypeCHARACTER,
- FFEINFO_kindtypeCHARACTER8);
- ffebld_constantunion_dump (ffebld_constant_union (c),
- FFEINFO_basictypeCHARACTER, FFEINFO_kindtypeCHARACTER8);
- break;
-#endif
-
- case FFEBLD_constHOLLERITH:
- fprintf (dmpout, "H%" ffetargetHollerithSize_f "u/",
- ffebld_constant_hollerith (c).length);
- ffetarget_print_hollerith (dmpout, ffebld_constant_hollerith (c));
- break;
-
- case FFEBLD_constBINARY_MIL:
- fprintf (dmpout, "BM/");
- ffetarget_print_binarymil (dmpout, ffebld_constant_typeless (c));
- break;
-
- case FFEBLD_constBINARY_VXT:
- fprintf (dmpout, "BV/");
- ffetarget_print_binaryvxt (dmpout, ffebld_constant_typeless (c));
- break;
-
- case FFEBLD_constOCTAL_MIL:
- fprintf (dmpout, "OM/");
- ffetarget_print_octalmil (dmpout, ffebld_constant_typeless (c));
- break;
-
- case FFEBLD_constOCTAL_VXT:
- fprintf (dmpout, "OV/");
- ffetarget_print_octalvxt (dmpout, ffebld_constant_typeless (c));
- break;
-
- case FFEBLD_constHEX_X_MIL:
- fprintf (dmpout, "XM/");
- ffetarget_print_hexxmil (dmpout, ffebld_constant_typeless (c));
- break;
-
- case FFEBLD_constHEX_X_VXT:
- fprintf (dmpout, "XV/");
- ffetarget_print_hexxvxt (dmpout, ffebld_constant_typeless (c));
- break;
-
- case FFEBLD_constHEX_Z_MIL:
- fprintf (dmpout, "ZM/");
- ffetarget_print_hexzmil (dmpout, ffebld_constant_typeless (c));
- break;
-
- case FFEBLD_constHEX_Z_VXT:
- fprintf (dmpout, "ZV/");
- ffetarget_print_hexzvxt (dmpout, ffebld_constant_typeless (c));
- break;
-
- default:
- assert ("bad constant type" == NULL);
- fprintf (dmpout, "?/?");
- break;
- }
-}
-#endif
-
/* ffebld_constant_is_magical -- Determine if integer is "magical"
ffebldConstant c;
return nc;
}
-/* ffebld_constantarray_dump -- Display summary of array's contents
-
- ffebldConstantArray a;
- ffeinfoBasictype bt;
- ffeinfoKindtype kt;
- ffetargetOffset size;
- ffebld_constant_dump(a,bt,kt,size,NULL);
+/* ffebld_constantarray_get -- Get a value from an array of constants
- Displays the constant array in summary form. The fifth argument, if
- supplied, is an ffebit object that is consulted as to whether the
- constant at a particular offset is valid. */
+ See prototype. */
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
-void
-ffebld_constantarray_dump (ffebldConstantArray array, ffeinfoBasictype bt,
- ffeinfoKindtype kt, ffetargetOffset size, ffebit bits)
+ffebldConstantUnion
+ffebld_constantarray_get (ffebldConstantArray array, ffeinfoBasictype bt,
+ ffeinfoKindtype kt, ffetargetOffset offset)
{
- ffetargetOffset i;
- ffebitCount j;
-
- ffebld_dump_prefix (dmpout, bt, kt);
-
- fprintf (dmpout, "\\(");
+ ffebldConstantUnion u;
- if (bits == NULL)
- {
- for (i = 0; i < size; ++i)
- {
- ffebld_constantunion_dump (ffebld_constantarray_get (array, bt, kt, i), bt,
- kt);
- if (i != size - 1)
- fputc (',', dmpout);
- }
- }
- else
- {
- bool value;
- ffebitCount length;
- ffetargetOffset offset = 0;
-
- do
- {
- ffebit_test (bits, offset, &value, &length);
- if (value && (length != 0))
- {
- if (length == 1)
- fprintf (dmpout, "[%" ffetargetOffset_f "d]:", offset);
- else
- fprintf (dmpout,
- "[%" ffetargetOffset_f "u..%" ffetargetOffset_f "d]:",
- offset, offset + (ffetargetOffset) length - 1);
- for (j = 0; j < length; ++j, ++offset)
- {
- ffebld_constantunion_dump (ffebld_constantarray_get (array, bt, kt,
- offset), bt, kt);
- if (j != length - 1)
- fputc (',', dmpout);
- }
- fprintf (dmpout, ";");
- }
- else
- offset += length;
- }
- while (length != 0);
- }
- fprintf (dmpout, "\\)");
-
-}
-#endif
-
-/* ffebld_constantarray_get -- Get a value from an array of constants
-
- See prototype. */
-
-ffebldConstantUnion
-ffebld_constantarray_get (ffebldConstantArray array, ffeinfoBasictype bt,
- ffeinfoKindtype kt, ffetargetOffset offset)
-{
- ffebldConstantUnion u;
-
- switch (bt)
+ switch (bt)
{
case FFEINFO_basictypeINTEGER:
switch (kt)
}
}
-/* ffebld_constantunion_dump -- Dump a constant
-
- See prototype. */
-
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
-void
-ffebld_constantunion_dump (ffebldConstantUnion u, ffeinfoBasictype bt,
- ffeinfoKindtype kt)
-{
- switch (bt)
- {
- case FFEINFO_basictypeINTEGER:
- switch (kt)
- {
-#if FFETARGET_okINTEGER1
- case FFEINFO_kindtypeINTEGER1:
- ffetarget_print_integer1 (dmpout, u.integer1);
- break;
-#endif
-
-#if FFETARGET_okINTEGER2
- case FFEINFO_kindtypeINTEGER2:
- ffetarget_print_integer2 (dmpout, u.integer2);
- break;
-#endif
-
-#if FFETARGET_okINTEGER3
- case FFEINFO_kindtypeINTEGER3:
- ffetarget_print_integer3 (dmpout, u.integer3);
- break;
-#endif
-
-#if FFETARGET_okINTEGER4
- case FFEINFO_kindtypeINTEGER4:
- ffetarget_print_integer4 (dmpout, u.integer4);
- break;
-#endif
-
-#if FFETARGET_okINTEGER5
- case FFEINFO_kindtypeINTEGER5:
- ffetarget_print_integer5 (dmpout, u.integer5);
- break;
-#endif
-
-#if FFETARGET_okINTEGER6
- case FFEINFO_kindtypeINTEGER6:
- ffetarget_print_integer6 (dmpout, u.integer6);
- break;
-#endif
-
-#if FFETARGET_okINTEGER7
- case FFEINFO_kindtypeINTEGER7:
- ffetarget_print_integer7 (dmpout, u.integer7);
- break;
-#endif
-
-#if FFETARGET_okINTEGER8
- case FFEINFO_kindtypeINTEGER8:
- ffetarget_print_integer8 (dmpout, u.integer8);
- break;
-#endif
-
- default:
- assert ("bad INTEGER kindtype" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeLOGICAL:
- switch (kt)
- {
-#if FFETARGET_okLOGICAL1
- case FFEINFO_kindtypeLOGICAL1:
- ffetarget_print_logical1 (dmpout, u.logical1);
- break;
-#endif
-
-#if FFETARGET_okLOGICAL2
- case FFEINFO_kindtypeLOGICAL2:
- ffetarget_print_logical2 (dmpout, u.logical2);
- break;
-#endif
-
-#if FFETARGET_okLOGICAL3
- case FFEINFO_kindtypeLOGICAL3:
- ffetarget_print_logical3 (dmpout, u.logical3);
- break;
-#endif
-
-#if FFETARGET_okLOGICAL4
- case FFEINFO_kindtypeLOGICAL4:
- ffetarget_print_logical4 (dmpout, u.logical4);
- break;
-#endif
-
-#if FFETARGET_okLOGICAL5
- case FFEINFO_kindtypeLOGICAL5:
- ffetarget_print_logical5 (dmpout, u.logical5);
- break;
-#endif
-
-#if FFETARGET_okLOGICAL6
- case FFEINFO_kindtypeLOGICAL6:
- ffetarget_print_logical6 (dmpout, u.logical6);
- break;
-#endif
-
-#if FFETARGET_okLOGICAL7
- case FFEINFO_kindtypeLOGICAL7:
- ffetarget_print_logical7 (dmpout, u.logical7);
- break;
-#endif
-
-#if FFETARGET_okLOGICAL8
- case FFEINFO_kindtypeLOGICAL8:
- ffetarget_print_logical8 (dmpout, u.logical8);
- break;
-#endif
-
- default:
- assert ("bad LOGICAL kindtype" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeREAL:
- switch (kt)
- {
-#if FFETARGET_okREAL1
- case FFEINFO_kindtypeREAL1:
- ffetarget_print_real1 (dmpout, u.real1);
- break;
-#endif
-
-#if FFETARGET_okREAL2
- case FFEINFO_kindtypeREAL2:
- ffetarget_print_real2 (dmpout, u.real2);
- break;
-#endif
-
-#if FFETARGET_okREAL3
- case FFEINFO_kindtypeREAL3:
- ffetarget_print_real3 (dmpout, u.real3);
- break;
-#endif
-
-#if FFETARGET_okREAL4
- case FFEINFO_kindtypeREAL4:
- ffetarget_print_real4 (dmpout, u.real4);
- break;
-#endif
-
-#if FFETARGET_okREAL5
- case FFEINFO_kindtypeREAL5:
- ffetarget_print_real5 (dmpout, u.real5);
- break;
-#endif
-
-#if FFETARGET_okREAL6
- case FFEINFO_kindtypeREAL6:
- ffetarget_print_real6 (dmpout, u.real6);
- break;
-#endif
-
-#if FFETARGET_okREAL7
- case FFEINFO_kindtypeREAL7:
- ffetarget_print_real7 (dmpout, u.real7);
- break;
-#endif
-
-#if FFETARGET_okREAL8
- case FFEINFO_kindtypeREAL8:
- ffetarget_print_real8 (dmpout, u.real8);
- break;
-#endif
-
- default:
- assert ("bad REAL kindtype" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeCOMPLEX:
- switch (kt)
- {
-#if FFETARGET_okCOMPLEX1
- case FFEINFO_kindtypeREAL1:
- fprintf (dmpout, "(");
- ffetarget_print_real1 (dmpout, u.complex1.real);
- fprintf (dmpout, ",");
- ffetarget_print_real1 (dmpout, u.complex1.imaginary);
- fprintf (dmpout, ")");
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX2
- case FFEINFO_kindtypeREAL2:
- fprintf (dmpout, "(");
- ffetarget_print_real2 (dmpout, u.complex2.real);
- fprintf (dmpout, ",");
- ffetarget_print_real2 (dmpout, u.complex2.imaginary);
- fprintf (dmpout, ")");
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX3
- case FFEINFO_kindtypeREAL3:
- fprintf (dmpout, "(");
- ffetarget_print_real3 (dmpout, u.complex3.real);
- fprintf (dmpout, ",");
- ffetarget_print_real3 (dmpout, u.complex3.imaginary);
- fprintf (dmpout, ")");
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX4
- case FFEINFO_kindtypeREAL4:
- fprintf (dmpout, "(");
- ffetarget_print_real4 (dmpout, u.complex4.real);
- fprintf (dmpout, ",");
- ffetarget_print_real4 (dmpout, u.complex4.imaginary);
- fprintf (dmpout, ")");
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX5
- case FFEINFO_kindtypeREAL5:
- fprintf (dmpout, "(");
- ffetarget_print_real5 (dmpout, u.complex5.real);
- fprintf (dmpout, ",");
- ffetarget_print_real5 (dmpout, u.complex5.imaginary);
- fprintf (dmpout, ")");
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX6
- case FFEINFO_kindtypeREAL6:
- fprintf (dmpout, "(");
- ffetarget_print_real6 (dmpout, u.complex6.real);
- fprintf (dmpout, ",");
- ffetarget_print_real6 (dmpout, u.complex6.imaginary);
- fprintf (dmpout, ")");
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX7
- case FFEINFO_kindtypeREAL7:
- fprintf (dmpout, "(");
- ffetarget_print_real7 (dmpout, u.complex7.real);
- fprintf (dmpout, ",");
- ffetarget_print_real7 (dmpout, u.complex7.imaginary);
- fprintf (dmpout, ")");
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX8
- case FFEINFO_kindtypeREAL8:
- fprintf (dmpout, "(");
- ffetarget_print_real8 (dmpout, u.complex8.real);
- fprintf (dmpout, ",");
- ffetarget_print_real8 (dmpout, u.complex8.imaginary);
- fprintf (dmpout, ")");
- break;
-#endif
-
- default:
- assert ("bad COMPLEX kindtype" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeCHARACTER:
- switch (kt)
- {
-#if FFETARGET_okCHARACTER1
- case FFEINFO_kindtypeCHARACTER1:
- ffetarget_print_character1 (dmpout, u.character1);
- break;
-#endif
-
-#if FFETARGET_okCHARACTER2
- case FFEINFO_kindtypeCHARACTER2:
- ffetarget_print_character2 (dmpout, u.character2);
- break;
-#endif
-
-#if FFETARGET_okCHARACTER3
- case FFEINFO_kindtypeCHARACTER3:
- ffetarget_print_character3 (dmpout, u.character3);
- break;
-#endif
-
-#if FFETARGET_okCHARACTER4
- case FFEINFO_kindtypeCHARACTER4:
- ffetarget_print_character4 (dmpout, u.character4);
- break;
-#endif
-
-#if FFETARGET_okCHARACTER5
- case FFEINFO_kindtypeCHARACTER5:
- ffetarget_print_character5 (dmpout, u.character5);
- break;
-#endif
-
-#if FFETARGET_okCHARACTER6
- case FFEINFO_kindtypeCHARACTER6:
- ffetarget_print_character6 (dmpout, u.character6);
- break;
-#endif
-
-#if FFETARGET_okCHARACTER7
- case FFEINFO_kindtypeCHARACTER7:
- ffetarget_print_character7 (dmpout, u.character7);
- break;
-#endif
-
-#if FFETARGET_okCHARACTER8
- case FFEINFO_kindtypeCHARACTER8:
- ffetarget_print_character8 (dmpout, u.character8);
- break;
-#endif
-
- default:
- assert ("bad CHARACTER kindtype" == NULL);
- break;
- }
- break;
-
- default:
- assert ("bad basictype" == NULL);
- break;
- }
-}
-#endif
-
-/* ffebld_dump -- Dump expression tree in concise form
-
- ffebld b;
- ffebld_dump(b); */
-
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
-void
-ffebld_dump (ffebld b)
-{
- ffeinfoKind k;
- ffeinfoWhere w;
-
- if (b == NULL)
- {
- fprintf (dmpout, "(null)");
- return;
- }
-
- switch (ffebld_op (b))
- {
- case FFEBLD_opITEM:
- fputs ("[", dmpout);
- while (b != NULL)
- {
- ffebld_dump (ffebld_head (b));
- if ((b = ffebld_trail (b)) != NULL)
- fputs (",", dmpout);
- }
- fputs ("]", dmpout);
- return;
-
- case FFEBLD_opSTAR:
- case FFEBLD_opBOUNDS:
- case FFEBLD_opREPEAT:
- case FFEBLD_opLABTER:
- case FFEBLD_opLABTOK:
- case FFEBLD_opIMPDO:
- fputs (ffebld_op_string (ffebld_op (b)), dmpout);
- break;
-
- default:
- if (ffeinfo_size (ffebld_info (b)) != FFETARGET_charactersizeNONE)
- fprintf (dmpout, "%s%d%s%s*%" ffetargetCharacterSize_f "u",
- ffebld_op_string (ffebld_op (b)),
- (int) ffeinfo_rank (ffebld_info (b)),
- ffeinfo_basictype_string (ffeinfo_basictype (ffebld_info (b))),
- ffeinfo_kindtype_string (ffeinfo_kindtype (ffebld_info (b))),
- ffeinfo_size (ffebld_info (b)));
- else
- fprintf (dmpout, "%s%d%s%s", ffebld_op_string (ffebld_op (b)),
- (int) ffeinfo_rank (ffebld_info (b)),
- ffeinfo_basictype_string (ffeinfo_basictype (ffebld_info (b))),
- ffeinfo_kindtype_string (ffeinfo_kindtype (ffebld_info (b))));
- if ((k = ffeinfo_kind (ffebld_info (b))) != FFEINFO_kindNONE)
- fprintf (dmpout, "/%s", ffeinfo_kind_string (k));
- if ((w = ffeinfo_where (ffebld_info (b))) != FFEINFO_whereNONE)
- fprintf (dmpout, "@%s", ffeinfo_where_string (w));
- break;
- }
-
- switch (ffebld_arity (b))
- {
- case 2:
- fputs ("(", dmpout);
- ffebld_dump (ffebld_left (b));
- fputs (",", dmpout);
- ffebld_dump (ffebld_right (b));
- fputs (")", dmpout);
- break;
-
- case 1:
- fputs ("(", dmpout);
- ffebld_dump (ffebld_left (b));
- fputs (")", dmpout);
- break;
-
- default:
- switch (ffebld_op (b))
- {
- case FFEBLD_opCONTER:
- fprintf (dmpout, "<");
- ffebld_constant_dump (b->u.conter.expr);
- fprintf (dmpout, ">");
- break;
-
- case FFEBLD_opACCTER:
- fprintf (dmpout, "<");
- ffebld_constantarray_dump (b->u.accter.array,
- ffeinfo_basictype (ffebld_info (b)),
- ffeinfo_kindtype (ffebld_info (b)),
- ffebit_size (b->u.accter.bits), b->u.accter.bits);
- fprintf (dmpout, ">");
- break;
-
- case FFEBLD_opARRTER:
- fprintf (dmpout, "<");
- ffebld_constantarray_dump (b->u.arrter.array,
- ffeinfo_basictype (ffebld_info (b)),
- ffeinfo_kindtype (ffebld_info (b)),
- b->u.arrter.size, NULL);
- fprintf (dmpout, ">");
- break;
-
- case FFEBLD_opLABTER:
- if (b->u.labter == NULL)
- fprintf (dmpout, "<>");
- else
- fprintf (dmpout, "<%" ffelabValue_f "u>", ffelab_value (b->u.labter));
- break;
-
- case FFEBLD_opLABTOK:
- fprintf (dmpout, "<%s>", ffelex_token_text (b->u.labtok));
- break;
-
- case FFEBLD_opSYMTER:
- fprintf (dmpout, "<");
- ffesymbol_dump (b->u.symter.symbol);
- if ((b->u.symter.generic != FFEINTRIN_genNONE)
- || (b->u.symter.specific != FFEINTRIN_specNONE))
- fprintf (dmpout, "{%s:%s:%s}",
- ffeintrin_name_generic (b->u.symter.generic),
- ffeintrin_name_specific (b->u.symter.specific),
- ffeintrin_name_implementation (b->u.symter.implementation));
- if (b->u.symter.do_iter)
- fprintf (dmpout, "{/do-iter}");
- fprintf (dmpout, ">");
- break;
-
- default:
- break;
- }
- }
-}
-#endif
-
-/* ffebld_dump_prefix -- Dump the prefix for a constant of a given type
-
- ffebld_dump_prefix(dmpout,FFEINFO_basictypeINTEGER,
- FFEINFO_kindtypeINTEGER1); */
-
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
-void
-ffebld_dump_prefix (FILE *out, ffeinfoBasictype bt, ffeinfoKindtype kt)
-{
- switch (bt)
- {
- case FFEINFO_basictypeINTEGER:
- switch (kt)
- {
-#if FFETARGET_okINTEGER1
- case FFEINFO_kindtypeINTEGER1:
- fprintf (out, "I" STRX (FFETARGET_kindINTEGER1) "/");
- break;
-#endif
-
-#if FFETARGET_okINTEGER2
- case FFEINFO_kindtypeINTEGER2:
- fprintf (out, "I" STRX (FFETARGET_kindINTEGER2) "/");
- break;
-#endif
-
-#if FFETARGET_okINTEGER3
- case FFEINFO_kindtypeINTEGER3:
- fprintf (out, "I" STRX (FFETARGET_kindINTEGER3) "/");
- break;
-#endif
-
-#if FFETARGET_okINTEGER4
- case FFEINFO_kindtypeINTEGER4:
- fprintf (out, "I" STRX (FFETARGET_kindINTEGER4) "/");
- break;
-#endif
-
-#if FFETARGET_okINTEGER5
- case FFEINFO_kindtypeINTEGER5:
- fprintf (out, "I" STRX (FFETARGET_kindINTEGER5) "/");
- break;
-#endif
-
-#if FFETARGET_okINTEGER6
- case FFEINFO_kindtypeINTEGER6:
- fprintf (out, "I" STRX (FFETARGET_kindINTEGER6) "/");
- break;
-#endif
-
-#if FFETARGET_okINTEGER7
- case FFEINFO_kindtypeINTEGER7:
- fprintf (out, "I" STRX (FFETARGET_kindINTEGER7) "/");
- break;
-#endif
-
-#if FFETARGET_okINTEGER8
- case FFEINFO_kindtypeINTEGER8:
- fprintf (out, "I" STRX (FFETARGET_kindINTEGER8) "/");
- break;
-#endif
-
- default:
- assert ("bad INTEGER kindtype" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeLOGICAL:
- switch (kt)
- {
-#if FFETARGET_okLOGICAL1
- case FFEINFO_kindtypeLOGICAL1:
- fprintf (out, "L" STRX (FFETARGET_kindLOGICAL1) "/");
- break;
-#endif
-
-#if FFETARGET_okLOGICAL2
- case FFEINFO_kindtypeLOGICAL2:
- fprintf (out, "L" STRX (FFETARGET_kindLOGICAL2) "/");
- break;
-#endif
-
-#if FFETARGET_okLOGICAL3
- case FFEINFO_kindtypeLOGICAL3:
- fprintf (out, "L" STRX (FFETARGET_kindLOGICAL3) "/");
- break;
-#endif
-
-#if FFETARGET_okLOGICAL4
- case FFEINFO_kindtypeLOGICAL4:
- fprintf (out, "L" STRX (FFETARGET_kindLOGICAL4) "/");
- break;
-#endif
-
-#if FFETARGET_okLOGICAL5
- case FFEINFO_kindtypeLOGICAL5:
- fprintf (out, "L" STRX (FFETARGET_kindLOGICAL5) "/");
- break;
-#endif
-
-#if FFETARGET_okLOGICAL6
- case FFEINFO_kindtypeLOGICAL6:
- fprintf (out, "L" STRX (FFETARGET_kindLOGICAL6) "/");
- break;
-#endif
-
-#if FFETARGET_okLOGICAL7
- case FFEINFO_kindtypeLOGICAL7:
- fprintf (out, "L" STRX (FFETARGET_kindLOGICAL7) "/");
- break;
-#endif
-
-#if FFETARGET_okLOGICAL8
- case FFEINFO_kindtypeLOGICAL8:
- fprintf (out, "L" STRX (FFETARGET_kindLOGICAL8) "/");
- break;
-#endif
-
- default:
- assert ("bad LOGICAL kindtype" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeREAL:
- switch (kt)
- {
-#if FFETARGET_okREAL1
- case FFEINFO_kindtypeREAL1:
- fprintf (out, "R" STRX (FFETARGET_kindREAL1) "/");
- break;
-#endif
-
-#if FFETARGET_okREAL2
- case FFEINFO_kindtypeREAL2:
- fprintf (out, "R" STRX (FFETARGET_kindREAL2) "/");
- break;
-#endif
-
-#if FFETARGET_okREAL3
- case FFEINFO_kindtypeREAL3:
- fprintf (out, "R" STRX (FFETARGET_kindREAL3) "/");
- break;
-#endif
-
-#if FFETARGET_okREAL4
- case FFEINFO_kindtypeREAL4:
- fprintf (out, "R" STRX (FFETARGET_kindREAL4) "/");
- break;
-#endif
-
-#if FFETARGET_okREAL5
- case FFEINFO_kindtypeREAL5:
- fprintf (out, "R" STRX (FFETARGET_kindREAL5) "/");
- break;
-#endif
-
-#if FFETARGET_okREAL6
- case FFEINFO_kindtypeREAL6:
- fprintf (out, "R" STRX (FFETARGET_kindREAL6) "/");
- break;
-#endif
-
-#if FFETARGET_okREAL7
- case FFEINFO_kindtypeREAL7:
- fprintf (out, "R" STRX (FFETARGET_kindREAL7) "/");
- break;
-#endif
-
-#if FFETARGET_okREAL8
- case FFEINFO_kindtypeREAL8:
- fprintf (out, "R" STRX (FFETARGET_kindREAL8) "/");
- break;
-#endif
-
- default:
- assert ("bad REAL kindtype" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeCOMPLEX:
- switch (kt)
- {
-#if FFETARGET_okCOMPLEX1
- case FFEINFO_kindtypeREAL1:
- fprintf (out, "C" STRX (FFETARGET_kindCOMPLEX1) "/");
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX2
- case FFEINFO_kindtypeREAL2:
- fprintf (out, "C" STRX (FFETARGET_kindCOMPLEX2) "/");
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX3
- case FFEINFO_kindtypeREAL3:
- fprintf (out, "C" STRX (FFETARGET_kindCOMPLEX3) "/");
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX4
- case FFEINFO_kindtypeREAL4:
- fprintf (out, "C" STRX (FFETARGET_kindCOMPLEX4) "/");
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX5
- case FFEINFO_kindtypeREAL5:
- fprintf (out, "C" STRX (FFETARGET_kindCOMPLEX5) "/");
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX6
- case FFEINFO_kindtypeREAL6:
- fprintf (out, "C" STRX (FFETARGET_kindCOMPLEX6) "/");
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX7
- case FFEINFO_kindtypeREAL7:
- fprintf (out, "C" STRX (FFETARGET_kindCOMPLEX7) "/");
- break;
-#endif
-
-#if FFETARGET_okCOMPLEX8
- case FFEINFO_kindtypeREAL8:
- fprintf (out, "C" STRX (FFETARGET_kindCOMPLEX8) "/");
- break;
-#endif
-
- default:
- assert ("bad COMPLEX kindtype" == NULL);
- break;
- }
- break;
-
- case FFEINFO_basictypeCHARACTER:
- switch (kt)
- {
-#if FFETARGET_okCHARACTER1
- case FFEINFO_kindtypeCHARACTER1:
- fprintf (out, "A" STRX (FFETARGET_kindCHARACTER1) "/");
- break;
-#endif
-
-#if FFETARGET_okCHARACTER2
- case FFEINFO_kindtypeCHARACTER2:
- fprintf (out, "A" STRX (FFETARGET_kindCHARACTER2) "/");
- break;
-#endif
-
-#if FFETARGET_okCHARACTER3
- case FFEINFO_kindtypeCHARACTER3:
- fprintf (out, "A" STRX (FFETARGET_kindCHARACTER3) "/");
- break;
-#endif
-
-#if FFETARGET_okCHARACTER4
- case FFEINFO_kindtypeCHARACTER4:
- fprintf (out, "A" STRX (FFETARGET_kindCHARACTER4) "/");
- break;
-#endif
-
-#if FFETARGET_okCHARACTER5
- case FFEINFO_kindtypeCHARACTER5:
- fprintf (out, "A" STRX (FFETARGET_kindCHARACTER5) "/");
- break;
-#endif
-
-#if FFETARGET_okCHARACTER6
- case FFEINFO_kindtypeCHARACTER6:
- fprintf (out, "A" STRX (FFETARGET_kindCHARACTER6) "/");
- break;
-#endif
-
-#if FFETARGET_okCHARACTER7
- case FFEINFO_kindtypeCHARACTER7:
- fprintf (out, "A" STRX (FFETARGET_kindCHARACTER7) "/");
- break;
-#endif
-
-#if FFETARGET_okCHARACTER8
- case FFEINFO_kindtypeCHARACTER8:
- fprintf (out, "A" STRX (FFETARGET_kindCHARACTER8) "/");
- break;
-#endif
-
- default:
- assert ("bad CHARACTER kindtype" == NULL);
- break;
- }
- break;
-
- default:
- assert ("bad basictype" == NULL);
- fprintf (out, "?/?");
- break;
- }
-}
-#endif
-
/* ffebld_init_0 -- Initialize the module
ffebld_init_0(); */
#define FFEBLD_whereconstPROGUNIT_ 1
#define FFEBLD_whereconstFILE_ 2
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
-#define FFEBLD_whereconstCURRENT_ FFEBLD_whereconstPROGUNIT_
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
#define FFEBLD_whereconstCURRENT_ FFEBLD_whereconstFILE_
-#else
-#error
-#endif
/* Structure definitions. */
/* Declare functions with prototypes. */
int ffebld_constant_cmp (ffebldConstant c1, ffebldConstant c2);
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
-void ffebld_constant_dump (ffebldConstant c);
-#endif
bool ffebld_constant_is_magical (ffebldConstant c);
bool ffebld_constant_is_zero (ffebldConstant c);
#if FFETARGET_okCHARACTER1
ffebldConstant ffebld_constant_new_typeless_val (ffebldConst type,
ffetargetTypeless val);
ffebldConstant ffebld_constant_negated (ffebldConstant c);
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
-void ffebld_constantarray_dump (ffebldConstantArray array, ffeinfoBasictype bt,
- ffeinfoKindtype kt, ffetargetOffset size, ffebit bits);
-#endif
ffebldConstantUnion ffebld_constantarray_get (ffebldConstantArray array,
ffeinfoBasictype bt, ffeinfoKindtype kt, ffetargetOffset offset);
void ffebld_constantarray_kill (ffebldConstantArray array, ffeinfoBasictype bt,
ffeinfoBasictype cbt, ffeinfoKindtype ckt);
void ffebld_constantarray_put (ffebldConstantArray array, ffeinfoBasictype bt,
ffeinfoKindtype kt, ffetargetOffset offset, ffebldConstantUnion constant);
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
-void ffebld_constantunion_dump (ffebldConstantUnion u, ffeinfoBasictype bt,
- ffeinfoKindtype kt);
-void ffebld_dump (ffebld b);
-void ffebld_dump_prefix (FILE *out, ffeinfoBasictype bt, ffeinfoKindtype kt);
-#endif
void ffebld_init_0 (void);
void ffebld_init_1 (void);
void ffebld_init_2 (void);
/* Include files. */
#include "proj.h"
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
#include "flags.h"
#include "rtl.h"
#include "toplev.h"
#include "ggc.h"
#include "diagnostic.h"
#include "langhooks.h"
-#endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
-
-#define FFECOM_GCC_INCLUDE 1 /* Enable -I. */
/* VMS-specific definitions */
#ifdef VMS
/* Externals defined here. */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
-
/* ~~gcc/tree.h *should* declare this, because toplev.c and dwarfout.c
reference it. */
tree ffecom_f2c_ptr_to_ftnlen_type_node;
tree ffecom_f2c_ftnint_type_node;
tree ffecom_f2c_ptr_to_ftnint_type_node;
-#endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
/* Simple definitions and enumerations. */
/* Internal typedefs. */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
typedef struct _ffecom_concat_list_ ffecomConcatList_;
-#endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
/* Private include files. */
/* Internal structure definitions. */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
struct _ffecom_concat_list_
{
ffebld *exprs;
ffetargetCharacterSize minlen;
ffetargetCharacterSize maxlen;
};
-#endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
/* Static functions (internal). */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
static tree ffecom_arglist_expr_ (const char *argstring, ffebld args);
static tree ffecom_widest_expr_type_ (ffebld list);
static bool ffecom_overlap_ (tree dest_decl, tree dest_offset,
static tree ffecom_vardesc_dims_ (ffesymbol s);
static tree ffecom_convert_narrow_ (tree type, tree expr);
static tree ffecom_convert_widen_ (tree type, tree expr);
-#endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
/* These are static functions that parallel those found in the C front
end and thus have the same names. */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
static tree bison_rule_compstmt_ (void);
static void bison_rule_pushlevel_ (void);
static void delete_block (tree block);
static void store_parm_decls (int is_main_program);
static tree start_decl (tree decl, bool is_top_level);
static void start_function (tree name, tree type, int nested, int public);
-#endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
-#if FFECOM_GCC_INCLUDE
static void ffecom_file_ (const char *name);
static void ffecom_initialize_char_syntax_ (void);
static void ffecom_close_include_ (FILE *f);
static int ffecom_decode_include_option_ (char *spec);
static FILE *ffecom_open_include_ (char *name, ffewhereLine l,
ffewhereColumn c);
-#endif /* FFECOM_GCC_INCLUDE */
/* Static objects accessed by functions in this module. */
static ffesymbol ffecom_nested_entry_ = NULL;
static ffeinfoKind ffecom_primary_entry_kind_;
static bool ffecom_primary_entry_is_proc_;
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
static tree ffecom_outer_function_decl_;
static tree ffecom_previous_function_decl_;
static tree ffecom_which_entrypoint_decl_;
#include "com-rt.def"
#undef DEFGFRT
};
-#endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
/* Internal macros. */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
-
/* We let tm.h override the types used here, to handle trivial differences
such as the choice of unsigned int or long unsigned int for size_t.
When machines start needing nontrivial differences in the size type,
/* A list of LABEL_DECLs from outer contexts that are currently shadowed. */
static tree shadowed_labels;
-
-#endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
\f
/* Return the subscript expression, modified to do range-checking.
else
{
/* Array reference substring range checking. */
-
+
cond = ffecom_2 (LE_EXPR, integer_type_node,
low,
element);
and such might well be stable too, but for things like calculations,
we do need to calculate a snapshot of a value before picking at it. */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
static tree
ffecom_stabilize_aggregate_ (tree ref)
{
return result;
}
-#endif
/* A rip-off of gcc's convert.c convert_to_complex function,
reworked to handle complex implemented as C structures
(RECORD_TYPE with two fields, real and imaginary `r' and `i'). */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
static tree
ffecom_convert_to_complex_ (tree type, tree expr)
{
assert (TREE_CODE (type) == RECORD_TYPE);
subtype = TREE_TYPE (TYPE_FIELDS (type));
-
+
if (form == REAL_TYPE || form == INTEGER_TYPE || form == ENUMERAL_TYPE)
{
expr = convert (subtype, expr);
error ("pointer value used where a complex was expected");
else
error ("aggregate value used where a complex was expected");
-
+
return ffecom_2 (COMPLEX_EXPR, type,
convert (subtype, integer_zero_node),
convert (subtype, integer_zero_node));
}
-#endif
/* Like gcc's convert(), but crashes if widening might happen. */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
static tree
ffecom_convert_narrow_ (type, expr)
tree type, expr;
assert ("conversion to non-scalar type requested" == NULL);
return error_mark_node;
}
-#endif
/* Like gcc's convert(), but crashes if narrowing might happen. */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
static tree
ffecom_convert_widen_ (type, expr)
tree type, expr;
assert ("conversion to non-scalar type requested" == NULL);
return error_mark_node;
}
-#endif
/* Handles making a COMPLEX type, either the standard
(but buggy?) gbe way, or the safer (but less elegant?)
f2c way. */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
static tree
ffecom_make_complex_type_ (tree subtype)
{
return type;
}
-#endif
/* Chooses either the gbe or the f2c way to build a
complex constant. */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
static tree
ffecom_build_complex_constant_ (tree type, tree realpart, tree imagpart)
{
return bothparts;
}
-#endif
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
static tree
ffecom_arglist_expr_ (const char *c, ffebld expr)
{
return list;
}
-#endif
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
static tree
ffecom_widest_expr_type_ (ffebld list)
{
assert (t != NULL_TREE);
return t;
}
-#endif
/* Check whether a partial overlap between two expressions is possible.
change before it is finally modified. dest_* are the canonized
destination itself. */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
static bool
ffecom_overlap_ (tree dest_decl, tree dest_offset, tree dest_size,
tree source_tree, ffebld source UNUSED,
return TRUE; /* Destination and source overlap. */
}
-#endif
/* Check whether dest might overlap any of a list of arguments or is
in a COMMON area the callee might know about (and thus modify). */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
static bool
ffecom_args_overlapping_ (tree dest_tree, ffebld dest UNUSED,
tree args, tree callee_commons,
return FALSE;
}
-#endif
/* Build a string for a variable name as used by NAMELIST. This means that
if we're using the f2c library, we build an uppercase string, since
f2c does this. */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
static tree
ffecom_build_f2c_string_ (int i, const char *s)
{
}
}
-#endif
/* Returns CALL_EXPR or equivalent with given type (pass NULL_TREE for
type to just get whatever the function returns), handling the
f2c value-returning convention, if required, by prepending
to the arglist a pointer to a temporary to receive the return value. */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
static tree
ffecom_call_ (tree fn, ffeinfoKindtype kt, bool is_f2c_complex,
tree type, tree args, tree dest_tree,
return item;
}
-#endif
/* Given two arguments, transform them and make a call to the given
function via ffecom_call_. */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
static tree
ffecom_call_binop_ (tree fn, ffeinfoKindtype kt, bool is_f2c_complex,
tree type, ffebld left, ffebld right,
dest_tree, dest, dest_used, callee_commons,
scalar_args, hook);
}
-#endif
/* Return ptr/length args for char subexpression
Note that if with_null is TRUE, and the expression is an opCONTER,
a null byte is appended to the string. */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
static void
ffecom_char_args_x_ (tree *xitem, tree *length, ffebld expr, bool with_null)
{
*xitem = item;
}
-#endif
/* Check the size of the type to be sure it doesn't overflow the
"portable" capacities of the compiler back end. `dummy' types
must still enforce its size requirements, though, and the back
end takes care of this in stor-layout.c. */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
static tree
ffecom_check_size_overflow_ (ffesymbol s, tree type, bool dummy)
{
return type;
}
-#endif
/* Builds a length argument (PARM_DECL). Also wraps type in an array type
where the dimension info is (1:size) where <size> is ffesymbol_size(s) if
known, length_arg if not known (FFETARGET_charactersizeNONE). */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
static tree
ffecom_char_enhance_arg_ (tree *xtype, ffesymbol s)
{
else
tlen = ffecom_get_invented_identifier ("__g77_%s", "length");
tlen = build_decl (PARM_DECL, tlen, ffecom_f2c_ftnlen_type_node);
-#if BUILT_FOR_270
DECL_ARTIFICIAL (tlen) = 1;
-#endif
}
if (sz == FFETARGET_charactersizeNONE)
return tlen;
}
-#endif
/* ffecom_concat_list_gather_ -- Gather list of concatenated string exprs
ffecomConcatList_ catlist;
Scans expr for character subexpressions, updates and returns catlist
accordingly. */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
static ffecomConcatList_
ffecom_concat_list_gather_ (ffecomConcatList_ catlist, ffebld expr,
ffetargetCharacterSize max)
{
ffetargetCharacterSize sz;
-recurse: /* :::::::::::::::::::: */
+ recurse:
if (expr == NULL)
return catlist;
}
}
-#endif
/* ffecom_concat_list_kill_ -- Kill list of concatenated string exprs
ffecomConcatList_ catlist;
Anything allocated within the list info is deallocated. */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
static void
ffecom_concat_list_kill_ (ffecomConcatList_ catlist)
{
catlist.max * sizeof (catlist.exprs[0]));
}
-#endif
/* Make list of concatenated string exprs.
Returns a flattened list of concatenated subexpressions given a
tree of such expressions. */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
static ffecomConcatList_
ffecom_concat_list_new_ (ffebld expr, ffetargetCharacterSize max)
{
return ffecom_concat_list_gather_ (catlist, expr, max);
}
-#endif
-
/* Provide some kind of useful info on member of aggregate area,
since current g77/gcc technology does not provide debug info
on these members. */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
static void
ffecom_debug_kludge_ (tree aggr, const char *aggr_type, ffesymbol member,
tree member_type UNUSED, ffetargetOffset offset)
if (buff != &space[0])
malloc_kill_ks (malloc_pool_image (), buff, len + 1);
}
-#endif
/* ffecom_do_entry_ -- Do compilation of a particular entrypoint
Makes a public entry point that calls our private master fn (already
compiled). */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
static void
ffecom_do_entry_ (ffesymbol fn, int entrynum)
{
ffecom_doing_entry_ = FALSE;
}
-#endif
/* Transform expr into gcc tree with possible destination
Recursive descent on expr while making corresponding tree nodes and
with temporary that would be made in certain cases, temporary isn't
made, destination used instead, and dest_used flag set TRUE. */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
static tree
ffecom_expr_ (ffebld expr, tree dest_tree, ffebld dest,
bool *dest_used, bool assignp, bool widenp)
case FFEBLD_opUMINUS:
left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
- if (tree_type_x)
+ if (tree_type_x)
{
tree_type = tree_type_x;
left = convert (tree_type, left);
case FFEBLD_opADD:
left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
- if (tree_type_x)
+ if (tree_type_x)
{
tree_type = tree_type_x;
left = convert (tree_type, left);
case FFEBLD_opSUBTRACT:
left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
- if (tree_type_x)
+ if (tree_type_x)
{
tree_type = tree_type_x;
left = convert (tree_type, left);
case FFEBLD_opMULTIPLY:
left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
- if (tree_type_x)
+ if (tree_type_x)
{
tree_type = tree_type_x;
left = convert (tree_type, left);
case FFEBLD_opDIVIDE:
left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
- if (tree_type_x)
+ if (tree_type_x)
{
tree_type = tree_type_x;
left = convert (tree_type, left);
#endif
}
-#endif
/* Returns the tree that does the intrinsic invocation.
Note: this function applies only to intrinsics returning
CHARACTER*1 or non-CHARACTER results, and to intrinsic
subroutines. */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
static tree
ffecom_expr_intrinsic_ (ffebld expr, tree dest_tree,
ffebld dest, bool *dest_used)
the bottom of this source file. */
}
-#endif
/* For power (exponentiation) where right-hand operand is type INTEGER,
generate in-line code to do it the fast way (which, if the operand
is a constant, might just mean a series of multiplies). */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
static tree
ffecom_expr_power_integer_ (ffebld expr)
{
return result;
}
-#endif
/* ffecom_expr_transform_ -- Transform symbols in expr
ffebld expr; // FFE expression.
Recursive descent on expr while transforming any untransformed SYMTERs. */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
static void
ffecom_expr_transform_ (ffebld expr)
{
tree t;
ffesymbol s;
-tail_recurse: /* :::::::::::::::::::: */
+ tail_recurse:
if (expr == NULL)
return;
return;
}
-#endif
/* Make a type based on info in live f2c.h file. */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
static void
ffecom_f2c_make_type_ (tree *type, int tcode, const char *name)
{
*type));
}
-#endif
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
/* Set the f2c list-directed-I/O code for whatever (integral) type has the
given size. */
}
}
-#endif
/* Finish up globals after doing all program units in file
Need to handle only uninitialized COMMON areas. */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
static ffeglobal
ffecom_finish_global_ (ffeglobal global)
{
return global;
}
-#endif
/* Finish up any untransformed symbols. */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
static ffesymbol
ffecom_finish_symbol_transform_ (ffesymbol s)
{
return s;
}
-#endif
/* Append underscore(s) to name before calling get_identifier. "us"
is nonzero if the name already contains an underscore and thus
needs two underscores appended. */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
static tree
ffecom_get_appended_identifier_ (char us, const char *name)
{
return id;
}
-#endif
/* Decide whether to append underscore to name before calling
get_identifier. */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
static tree
ffecom_get_external_identifier_ (ffesymbol s)
{
return ffecom_get_appended_identifier_ (us, name);
}
-#endif
/* Decide whether to append underscore to internal name before calling
get_identifier.
If the name does contain an underscore, then transform it just
like we transform an external identifier. */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
static tree
ffecom_get_identifier_ (const char *name)
{
name);
}
-#endif
/* ffecom_gen_sfuncdef_ -- Generate definition of statement function
tree t;
Call after setting up containing function and getting trees for all
other symbols. */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
static tree
ffecom_gen_sfuncdef_ (ffesymbol s, ffeinfoBasictype bt, ffeinfoKindtype kt)
{
return func;
}
-#endif
-
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
static const char *
ffecom_gfrt_args_ (ffecomGfrt ix)
{
return ffecom_gfrt_argstring_[ix];
}
-#endif
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
static tree
ffecom_gfrt_tree_ (ffecomGfrt ix)
{
ffecom_gfrt_[ix]);
}
-#endif
/* Return initialize-to-zero expression for this VAR_DECL. */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
/* A somewhat evil way to prevent the garbage collector
from collecting 'tree' structures. */
#define NUM_TRACKED_CHUNK 63
-static struct tree_ggc_tracker
+static struct tree_ggc_tracker
{
struct tree_ggc_tracker *next;
tree trees[NUM_TRACKED_CHUNK];
} *tracker_head = NULL;
-static void
+static void
mark_tracker_head (void *arg)
{
struct tree_ggc_tracker *head;
int i;
-
+
for (head = * (struct tree_ggc_tracker **) arg;
head != NULL;
head = head->next)
{
/* Need to allocate a new block. */
struct tree_ggc_tracker *old_head = tracker_head;
-
+
tracker_head = ggc_alloc (sizeof (*tracker_head));
tracker_head->next = old_head;
tracker_head->trees[0] = t;
return init;
}
-#endif
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
static tree
ffecom_intrinsic_ichar_ (tree tree_type, ffebld arg,
tree *maybe_tree)
}
}
-#endif
/* ffecom_intrinsic_len_ -- Return length info for char arg (LEN())
tree length_arg;
subexpressions by constructing the appropriate tree for the
length-of-character-text argument in a calling sequence. */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
static tree
ffecom_intrinsic_len_ (ffebld expr)
{
return length;
}
-#endif
/* Handle CHARACTER assignments.
Generates code to do the assignment. Used by ordinary assignment
statement handler ffecom_let_stmt and by statement-function
handler to generate code for a statement function. */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
static void
ffecom_let_char_ (tree dest_tree, tree dest_length,
ffetargetCharacterSize dest_size, ffebld source)
ffecom_concat_list_kill_ (catlist);
}
-#endif
/* ffecom_make_gfrt_ -- Make initial info for run-time routine
ffecomGfrt ix;
Assumes gfrt_[ix] is NULL_TREE, and replaces it with the FUNCTION_DECL
for the indicated run-time routine (ix). */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
static void
ffecom_make_gfrt_ (ffecomGfrt ix)
{
ffecom_gfrt_[ix] = t;
}
-#endif
/* Phase 1 pass over each member of a COMMON/EQUIVALENCE group. */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
static void
ffecom_member_phase1_ (ffestorag mst UNUSED, ffestorag st)
{
ffecom_member_namelisted_ = TRUE;
}
-#endif
/* Phase 2 pass over each member of a COMMON/EQUIVALENCE group. Declare
the member so debugger will see it. Otherwise nobody should be
referencing the member. */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
static void
ffecom_member_phase2_ (ffestorag mst, ffestorag st)
{
finish_decl (t, NULL_TREE, FALSE);
}
-#endif
/* Prepare source expression for assignment into a destination perhaps known
to be of a specific size. */
always known by both the caller and the callee, though the code allows
for someday permitting CHAR*(*) stmtfunc dummies). */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
static void
ffecom_push_dummy_decls_ (ffebld dummy_list, bool stmtfunc)
{
ffecom_transform_only_dummies_ = FALSE;
}
-#endif
/* ffecom_start_progunit_ -- Beginning of program unit
Does GNU back end stuff necessary to teach it about the start of its
equivalent of a Fortran program unit. */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
static void
ffecom_start_progunit_ ()
{
ffesymbol_drive (ffecom_finish_symbol_transform_);
}
-#endif
/* ffecom_sym_transform_ -- Transform FFE sym into backend sym
ffesymbol s;
The ffesymbol_hook info for s is updated with appropriate backend info
on the symbol. */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
static ffesymbol
ffecom_sym_transform_ (ffesymbol s)
{
t = build_decl (PARM_DECL,
ffecom_get_identifier_ (ffesymbol_text (s)),
ffecom_tree_ptr_to_subr_type);
-#if BUILT_FOR_270
DECL_ARTIFICIAL (t) = 1;
-#endif
addr = TRUE;
break;
}
t = build_decl (PARM_DECL, t, type);
-#if BUILT_FOR_270
DECL_ARTIFICIAL (t) = 1;
-#endif
/* If this arg is present in every entry point's list of
dummy args, then we're done. */
t = build_decl (PARM_DECL,
ffecom_get_identifier_ (ffesymbol_text (s)),
t);
-#if BUILT_FOR_270
DECL_ARTIFICIAL (t) = 1;
-#endif
addr = TRUE;
break;
t = build_decl (PARM_DECL,
ffecom_get_identifier_ (ffesymbol_text (s)),
ffecom_tree_ptr_to_subr_type);
-#if BUILT_FOR_270
DECL_ARTIFICIAL (t) = 1;
-#endif
addr = TRUE;
break;
return s;
}
-#endif
/* Transform into ASSIGNable symbol.
Symbol has already been transformed, but for whatever reason, the
another local symbol of type void * and stuff that in the assign_tree
argument. The F77/F90 standards allow this implementation. */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
static ffesymbol
ffecom_sym_transform_assign_ (ffesymbol s)
{
return s;
}
-#endif
/* Implement COMMON area in back end.
Because COMMON-based variables can be referenced in the dimension
though we might do that as well just for debugging purposes (and
stuff the rtl with the appropriate offset expression). */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
static void
ffecom_transform_common_ (ffesymbol s)
{
ffecom_save_tree_forever (cbt);
}
-#endif
/* Make master area for local EQUIVALENCE. */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
static void
ffecom_transform_equiv_ (ffestorag eqst)
{
eqst);
}
-#endif
/* Implement NAMELIST in back end. See f2c/format.c for more info. */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
static tree
ffecom_transform_namelist_ (ffesymbol s)
{
return nmlt;
}
-#endif
-
/* A subroutine of ffecom_tree_canonize_ref_. The incoming tree is
analyzed on the assumption it is calculating a pointer to be
indirected through. It must return the proper decl and offset,
taking into account different units of measurements for offsets. */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
static void
ffecom_tree_canonize_ptr_ (tree *decl, tree *offset,
tree t)
break;
}
}
-#endif
/* Given a tree that is possibly intended for use as an lvalue, return
information representing a canonical view of that tree as a decl, an
whereas converting the array offsets to consistant offsets will
reveal the overlap. */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
static void
ffecom_tree_canonize_ref_ (tree *decl, tree *offset,
tree *size, tree t)
return;
}
}
-#endif
/* Do divide operation appropriate to type of operands. */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
static tree
ffecom_tree_divide_ (tree tree_type, tree left, tree right,
tree dest_tree, ffebld dest, bool *dest_used,
}
}
-#endif
/* Build type info for non-dummy variable. */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
static tree
ffecom_type_localvar_ (ffesymbol s, ffeinfoBasictype bt,
ffeinfoKindtype kt)
return type;
}
-#endif
/* Build Namelist type. */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
static tree
ffecom_type_namelist_ ()
{
return type;
}
-#endif
-
/* Build Vardesc type. */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
static tree
ffecom_type_vardesc_ ()
{
return type;
}
-#endif
-
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
static tree
ffecom_vardesc_ (ffebld expr)
{
return ffesymbol_hook (s).vardesc_tree;
}
-#endif
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
static tree
ffecom_vardesc_array_ (ffesymbol s)
{
return var;
}
-#endif
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
static tree
ffecom_vardesc_dims_ (ffesymbol s)
{
}
}
-#endif
/* Essentially does a "fold (build1 (code, type, node))" while checking
for certain housekeeping things.
NOTE: for building an ADDR_EXPR around a FUNCTION_DECL, use
ffecom_1_fn instead. */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
tree
ffecom_1 (enum tree_code code, tree type, tree node)
{
TREE_CONSTANT (item) = 1;
return fold (item);
}
-#endif
/* Like ffecom_1 (ADDR_EXPR, TREE_TYPE (node), node), except
handles TREE_CODE (node) == FUNCTION_DECL. In particular,
function does not mean the function needs to be separately
compiled). */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
tree
ffecom_1_fn (tree node)
{
TREE_CONSTANT (item) = 1;
return fold (item);
}
-#endif
/* Essentially does a "fold (build (code, type, node1, node2))" while
checking for certain housekeeping things. */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
tree
ffecom_2 (enum tree_code code, tree type, tree node1,
tree node2)
return fold (item);
}
-#endif
/* ffecom_2pass_advise_entrypoint -- Advise that there's this entrypoint
ffesymbol s; // the ENTRY point itself
03-Jan-92 JCB 2.0
Return FALSE if the return type conflicts with previous entrypoints. */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
bool
ffecom_2pass_advise_entrypoint (ffesymbol entry)
{
return TRUE;
}
-#endif
/* ffecom_2pass_do_entrypoint -- Do compilation of entrypoint
ffesymbol s; // the ENTRY point itself
happen. Must be called for each entrypoint after
ffecom_finish_progunit is called. */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
void
ffecom_2pass_do_entrypoint (ffesymbol entry)
{
ffecom_do_entry_ (entry, ent_num);
}
-#endif
-
/* Essentially does a "fold (build (code, type, node1, node2))" while
checking for certain housekeeping things. Always sets
TREE_SIDE_EFFECTS. */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
tree
ffecom_2s (enum tree_code code, tree type, tree node1,
tree node2)
return fold (item);
}
-#endif
/* Essentially does a "fold (build (code, type, node1, node2, node3))" while
checking for certain housekeeping things. */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
tree
ffecom_3 (enum tree_code code, tree type, tree node1,
tree node2, tree node3)
return fold (item);
}
-#endif
/* Essentially does a "fold (build (code, type, node1, node2, node3))" while
checking for certain housekeeping things. Always sets
TREE_SIDE_EFFECTS. */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
tree
ffecom_3s (enum tree_code code, tree type, tree node1,
tree node2, tree node3)
return fold (item);
}
-#endif
-
/* ffecom_arg_expr -- Transform argument expr into gcc tree
See use by ffecom_list_expr.
we allow CHARACTER*(*) dummies to statement functions, we'll need
it). */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
tree
ffecom_arg_expr (ffebld expr, tree *length)
{
return ffecom_arg_ptr_to_expr (expr, &ign);
}
-#endif
/* Transform expression into constant argument-pointer-to-expression tree.
If the expression can be transformed into a argument-pointer-to-expression
length argument. This might even be seen as a feature, if a null
byte can always be appended. */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
tree
ffecom_arg_ptr_to_expr (ffebld expr, tree *length)
{
return item;
}
-#endif
/* Generate call to run-time function.
The first arg is the GNU Fortran Run-Time function index, the second
(WITHOUT TREE_SIDE_EFFECTS set!) that makes the call and returns the
result (which may be void). */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
tree
ffecom_call_gfrt (ffecomGfrt ix, tree args, tree hook)
{
NULL_TREE, args, NULL_TREE, NULL,
NULL, NULL_TREE, TRUE, hook);
}
-#endif
/* Transform constant-union to tree. */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
tree
ffecom_constantunion (ffebldConstantUnion *cu, ffeinfoBasictype bt,
ffeinfoKindtype kt, tree tree_type)
return item;
}
-#endif
-
/* Transform expression into constant tree.
If the expression can be transformed into a tree that is constant,
/* Handy way to make a field in a struct/union. */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
tree
ffecom_decl_field (tree context, tree prevfield,
const char *name, tree type)
return field;
}
-#endif
-
void
ffecom_close_include (FILE *f)
{
-#if FFECOM_GCC_INCLUDE
ffecom_close_include_ (f);
-#endif
}
int
ffecom_decode_include_option (char *spec)
{
-#if FFECOM_GCC_INCLUDE
return ffecom_decode_include_option_ (spec);
-#else
- return 1;
-#endif
}
/* End a compound statement (block). */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
tree
ffecom_end_compstmt (void)
{
return bison_rule_compstmt_ ();
}
-#endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
/* ffecom_end_transition -- Perform end transition on all symbols
void
ffecom_end_transition ()
{
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
ffebld item;
-#endif
if (ffe_is_ffedebug ())
fprintf (dmpout, "; end_stmt_transition\n");
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
ffecom_list_blockdata_ = NULL;
ffecom_list_common_ = NULL;
-#endif
ffesymbol_drive (ffecom_sym_end_transition);
if (ffe_is_ffedebug ())
{
ffestorag_report ();
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- ffesymbol_report_all ();
-#endif
}
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
ffecom_start_progunit_ ();
for (item = ffecom_list_blockdata_;
ffecom_transform_common_ (ffebld_symter (ffebld_head (item)));
ffecom_list_common_ = NULL;
-#endif
}
/* ffecom_exec_transition -- Perform exec transition on all symbols
if (ffe_is_ffedebug ())
{
ffestorag_report ();
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- ffesymbol_report_all ();
-#endif
}
if (inhibited)
Convert dest and source using ffecom_expr, then join them
with an ASSIGN op and pass the whole thing to expand_expr_stmt. */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
void
ffecom_expand_let_stmt (ffebld dest, ffebld source)
{
source);
}
-#endif
/* ffecom_expr -- Transform expr into gcc tree
tree t;
Recursive descent on expr while making corresponding tree nodes and
attaching type info and such. */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
tree
ffecom_expr (ffebld expr)
{
return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, FALSE, FALSE);
}
-#endif
/* Like ffecom_expr, but return tree usable for assigned GOTO or FORMAT. */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
tree
ffecom_expr_assign (ffebld expr)
{
return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, TRUE, FALSE);
}
-#endif
/* Like ffecom_expr_rw, but return tree usable for ASSIGN. */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
tree
ffecom_expr_assign_w (ffebld expr)
{
return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, TRUE, FALSE);
}
-#endif
/* Transform expr for use as into read/write tree and stabilize the
reference. Not for use on CHARACTER expressions.
Recursive descent on expr while making corresponding tree nodes and
attaching type info and such. */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
tree
ffecom_expr_rw (tree type, ffebld expr)
{
return stabilize_reference (ffecom_expr (expr));
}
-#endif
/* Transform expr for use as into write tree and stabilize the
reference. Not for use on CHARACTER expressions.
Recursive descent on expr while making corresponding tree nodes and
attaching type info and such. */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
tree
ffecom_expr_w (tree type, ffebld expr)
{
return stabilize_reference (ffecom_expr (expr));
}
-#endif
/* Do global stuff. */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
void
ffecom_finish_compile ()
{
ffeglobal_drive (ffecom_finish_global_);
}
-#endif
/* Public entry point for front end to access finish_decl. */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
void
ffecom_finish_decl (tree decl, tree init, bool is_top_level)
{
finish_decl (decl, init, FALSE);
}
-#endif
/* Finish a program unit. */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
void
ffecom_finish_progunit ()
{
finish_function (0);
}
-#endif
-
/* Wrapper for get_identifier. pattern is sprintf-like. */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
tree
ffecom_get_invented_identifier (const char *pattern, ...)
{
}
}
-#if FFECOM_GCC_INCLUDE
ffecom_initialize_char_syntax_ ();
-#endif
ffecom_outer_function_decl_ = NULL_TREE;
current_function_decl = NULL_TREE;
builtin_function ("__builtin_cosl", ldouble_ftype_ldouble,
BUILT_IN_COS, BUILT_IN_NORMAL, "cosl");
-#if BUILT_FOR_270
pedantic_lvalues = FALSE;
-#endif
ffecom_f2c_make_type_ (&ffecom_f2c_integer_type_node,
FFECOM_f2cINTEGER,
#endif
}
-#endif
/* ffecom_init_2 -- Initialize
ffecom_init_2(); */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
void
ffecom_init_2 ()
{
ffecom_multi_retval_ = NULL_TREE;
}
-#endif
/* ffecom_list_expr -- Transform list of exprs into gcc tree
tree t;
List of actual args is transformed into corresponding gcc backend list. */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
tree
ffecom_list_expr (ffebld expr)
{
return list;
}
-#endif
/* ffecom_list_ptr_to_expr -- Transform list of exprs into gcc tree
tree t;
List of actual args is transformed into corresponding gcc backend list for
use in calling an external procedure (vs. a statement function). */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
tree
ffecom_list_ptr_to_expr (ffebld expr)
{
return list;
}
-#endif
/* Obtain gcc's LABEL_DECL tree for label. */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
tree
ffecom_lookup_label (ffelab label)
{
return glabel;
}
-#endif
/* Stabilizes the arguments. Don't use this if the lhs and rhs come from
a single source specification (as in the fourth argument of MVBITS).
If the type is NULL_TREE, the type of lhs is used to make the type of
the MODIFY_EXPR. */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
tree
ffecom_modify (tree newtype, tree lhs,
tree rhs)
return ffecom_2s (MODIFY_EXPR, newtype, lhs, rhs);
}
-#endif
-
/* Register source file name. */
void
ffecom_file (const char *name)
{
-#if FFECOM_GCC_INCLUDE
ffecom_file_ (name);
-#endif
}
/* ffecom_notify_init_storage -- An aggregate storage is now fully init'ed
ffecom_notify_init_storage (ffestorag st)
{
ffebld init; /* The initialization expression. */
-#if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
- ffetargetOffset size; /* The size of the entity. */
- ffetargetAlign pad; /* Its initial padding. */
-#endif
if (ffestorag_init (st) == NULL)
{
assert (init != NULL);
ffestorag_set_accretion (st, NULL);
ffestorag_set_accretes (st, 0);
-
-#if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
- /* For GNU backend, just turn ACCTER into ARRTER and proceed. */
- size = ffebld_accter_size (init);
- pad = ffebld_accter_pad (init);
- ffebit_kill (ffebld_accter_bits (init));
- ffebld_set_op (init, FFEBLD_opARRTER);
- ffebld_set_arrter (init, ffebld_accter (init));
- ffebld_arrter_set_size (init, size);
- ffebld_arrter_set_pad (init, size);
-#endif
-
-#if FFECOM_TWOPASS
ffestorag_set_init (st, init);
-#endif
}
-#if FFECOM_ONEPASS
- else
- init = ffestorag_init (st);
-#endif
-
-#if FFECOM_ONEPASS /* Process the inits, wipe 'em out. */
- ffestorag_set_init (st, ffebld_new_any ());
-
- if (ffebld_op (init) == FFEBLD_opANY)
- return; /* Oh, we already did this! */
-
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- {
- ffesymbol s;
-
- if (ffestorag_symbol (st) != NULL)
- s = ffestorag_symbol (st);
- else
- s = ffestorag_typesymbol (st);
-
- fprintf (dmpout, "= initialize_storage \"%s\" ",
- (s != NULL) ? ffesymbol_text (s) : "(unnamed)");
- ffebld_dump (init);
- fputc ('\n', dmpout);
- }
-#endif
-
-#endif /* if FFECOM_ONEPASS */
}
/* ffecom_notify_init_symbol -- A symbol is now fully init'ed
ffecom_notify_init_symbol (ffesymbol s)
{
ffebld init; /* The initialization expression. */
-#if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
- ffetargetOffset size; /* The size of the entity. */
- ffetargetAlign pad; /* Its initial padding. */
-#endif
if (ffesymbol_storage (s) == NULL)
return; /* Do nothing until COMMON/EQUIVALENCE
{
ffesymbol_set_accretion (s, NULL);
ffesymbol_set_accretes (s, 0);
-
-#if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
- /* For GNU backend, just turn ACCTER into ARRTER and proceed. */
- size = ffebld_accter_size (init);
- pad = ffebld_accter_pad (init);
- ffebit_kill (ffebld_accter_bits (init));
- ffebld_set_op (init, FFEBLD_opARRTER);
- ffebld_set_arrter (init, ffebld_accter (init));
- ffebld_arrter_set_size (init, size);
- ffebld_arrter_set_pad (init, size);
-#endif
-
-#if FFECOM_TWOPASS
ffesymbol_set_init (s, init);
-#endif
}
-#if FFECOM_ONEPASS
- else
- init = ffesymbol_init (s);
-#endif
-
-#if FFECOM_ONEPASS
- ffesymbol_set_init (s, ffebld_new_any ());
-
- if (ffebld_op (init) == FFEBLD_opANY)
- return; /* Oh, we already did this! */
-
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- fprintf (dmpout, "= initialize_symbol \"%s\" ", ffesymbol_text (s));
- ffebld_dump (init);
- fputc ('\n', dmpout);
-#endif
-
-#endif /* if FFECOM_ONEPASS */
}
/* ffecom_notify_primary_entry -- Learn which is the primary entry point
fprintf (stderr, " %s:\n", ffesymbol_text (s));
}
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
if (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE)
{
ffebld list;
}
}
}
-#endif
}
FILE *
ffecom_open_include (char *name, ffewhereLine l, ffewhereColumn c)
{
-#if FFECOM_GCC_INCLUDE
return ffecom_open_include_ (name, l, c);
-#else
- return fopen (name, "r");
-#endif
}
/* ffecom_ptr_to_expr -- Transform expr into gcc tree with & in front
Like ffecom_expr, but sticks address-of in front of most things. */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
tree
ffecom_ptr_to_expr (ffebld expr)
{
return error_mark_node;
}
-#endif
/* Obtain a temp var with given data type.
size is FFETARGET_charactersizeNONE for a non-CHARACTER type
elements is -1 for a scalar or > 0 for an array of type. */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
tree
ffecom_make_tempvar (const char *commentary, tree type,
ffetargetCharacterSize size, int elements)
return t;
}
-#endif
/* Prepare argument pointer to expression.
meaning no return value or the caller expects it to be returned somewhere
else (which is handled by other parts of this module). */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
tree
ffecom_return_expr (ffebld expr)
{
return rtn;
}
-#endif
/* Do save_expr only if tree is not error_mark_node. */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
tree
ffecom_save_tree (tree t)
{
return save_expr (t);
}
-#endif
/* Start a compound statement (block). */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
void
ffecom_start_compstmt (void)
{
bison_rule_pushlevel_ ();
}
-#endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
/* Public entry point for front end to access start_decl. */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
tree
ffecom_start_decl (tree decl, bool is_initialized)
{
return start_decl (decl, FALSE);
}
-#endif
/* ffecom_sym_commit -- Symbol's state being committed to reality
ffesymbol s;
Does whatever the backend needs when a symbol is committed after having
been backtrackable for a period of time. */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
void
ffecom_sym_commit (ffesymbol s UNUSED)
{
assert (!ffesymbol_retractable ());
}
-#endif
/* ffecom_sym_end_transition -- Perform end transition on all symbols
ffecom_sym_end_transition();
s = ffest_sym_end_transition (s);
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
if ((ffesymbol_kind (s) == FFEINFO_kindBLOCKDATA)
&& (ffesymbol_where (s) == FFEINFO_whereGLOBAL))
{
FFEINTRIN_impNONE),
ffecom_list_blockdata_);
}
-#endif
/* This is where we finally notice that a symbol has partial initialization
and finalize it. */
ffecom_notify_init_storage (st);
}
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
if ((ffesymbol_kind (s) == FFEINFO_kindCOMMON)
&& (ffesymbol_where (s) == FFEINFO_whereLOCAL)
&& (ffesymbol_storage (s) != NULL))
FFEINTRIN_impNONE),
ffecom_list_common_);
}
-#endif
return s;
}
Does whatever the backend needs when a symbol is retracted after having
been backtrackable for a period of time. */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
void
ffecom_sym_retract (ffesymbol s UNUSED)
{
#endif
}
-#endif
/* Create temporary gcc label. */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
tree
ffecom_temp_label ()
{
return glabel;
}
-#endif
/* Return an expression that is usable as an arg in a conditional context
(IF, DO WHILE, .NOT., and so on).
Use the one provided for the back end as of >2.6.0. */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
tree
ffecom_truth_value (tree expr)
{
return truthvalue_conversion (expr);
}
-#endif
/* Return the inversion of a truth value (the inversion of what
ffecom_truth_value builds).
Apparently invert_truthvalue, which is properly in the back end, is
enough for now, so just use it. */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
tree
ffecom_truth_value_invert (tree expr)
{
return invert_truthvalue (ffecom_truth_value (expr));
}
-#endif
-
/* Return the tree that is the type of the expression, as would be
returned in TREE_TYPE(ffecom_expr(expr)), without otherwise
transforming the expression, generating temporaries, etc. */
run time with the entrypoint number (0 for SUBROUTINE/FUNCTION, 1 for
first ENTRY statement, and so on). */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
tree
ffecom_which_entrypoint_decl ()
{
return ffecom_which_entrypoint_decl_;
}
-
-#endif
\f
/* The following sections consists of private and public functions
that have the same names and perform roughly the same functions
Functions named after rule "foo:" in c-parse.y are named
"bison_rule_foo_" so they are easy to find. */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
-
static void
bison_rule_pushlevel_ ()
{
if (DECL_SECTION_NAME (newdecl) == NULL_TREE)
DECL_SECTION_NAME (newdecl) = DECL_SECTION_NAME (olddecl);
-#if BUILT_FOR_270
if (TREE_CODE (newdecl) == FUNCTION_DECL)
{
DECL_STATIC_CONSTRUCTOR(newdecl) |= DECL_STATIC_CONSTRUCTOR(olddecl);
DECL_STATIC_DESTRUCTOR (newdecl) |= DECL_STATIC_DESTRUCTOR (olddecl);
}
-#endif
}
/* If cannot merge, then use the new type and qualifiers,
and don't preserve the old rtl. */
/* g77's function to print out name of current function that caused
an error. */
-#if BUILT_FOR_270
static void
lang_print_error_function (diagnostic_context *context __attribute__((unused)),
const char *file)
last_s = s;
}
}
-#endif
/* Similar to `lookup_name' but look only at current binding level. */
}
/* Mark ARG for GC. */
-static void
+static void
mark_binding_level (void *arg)
{
struct binding_level *level = *(struct binding_level **) arg;
/* Record our roots. */
for (i = 0; i < ARRAY_SIZE (tree_roots); i++)
ggc_add_tree_root (tree_roots[i], 1);
- ggc_add_tree_root (&ffecom_tree_type[0][0],
+ ggc_add_tree_root (&ffecom_tree_type[0][0],
FFEINFO_basictype*FFEINFO_kindtype);
- ggc_add_tree_root (&ffecom_tree_fun_type[0][0],
+ ggc_add_tree_root (&ffecom_tree_fun_type[0][0],
FFEINFO_basictype*FFEINFO_kindtype);
- ggc_add_tree_root (&ffecom_tree_ptr_to_fun_type[0][0],
+ ggc_add_tree_root (&ffecom_tree_ptr_to_fun_type[0][0],
FFEINFO_basictype*FFEINFO_kindtype);
ggc_add_tree_root (ffecom_gfrt_, FFECOM_gfrt);
ggc_add_root (¤t_binding_level, 1, sizeof current_binding_level,
/* Make identifier nodes long enough for the language-specific slots. */
set_identifier_size (sizeof (struct lang_identifier));
decl_printable_name = lang_printable_name;
-#if BUILT_FOR_270
print_error_function = lang_print_error_function;
-#endif
return filename;
}
{
if (IDENTIFIER_INVENTED (name))
{
-#if BUILT_FOR_270
DECL_ARTIFICIAL (x) = 1;
-#endif
DECL_IN_SYSTEM_HEADER (x) = 1;
}
return type;
}
-void
+void
lang_mark_tree (t)
union tree_node *t ATTRIBUTE_UNUSED;
{
else if (TYPE_P (t) && TYPE_LANG_SPECIFIC (t))
ggc_mark (TYPE_LANG_SPECIFIC (t));
}
-
-#endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
\f
-#if FFECOM_GCC_INCLUDE
-
/* From gcc/cccp.c, the code to handle -I. */
/* Skip leading "./" from a directory name.
return f;
}
-#endif /* FFECOM_GCC_INCLUDE */
/**INDENT* (Do not reformat this comment even with -fca option.)
Data-gathering files: Given the source file listed below, compiled with
void pow_ci();
double pow_dd();
void pow_zz();
- double acos(), r_imag(), r_int(), log(), r_lg10(), r_mod(), r_nint(),
+ double acos(), r_imag(), r_int(), log(), r_lg10(), r_mod(), r_nint(),
asin(), atan(), atan2(), c_abs();
void c_cos(), c_exp(), c_log(), r_cnjg();
double cos(), cosh();
void c_sin(), c_sqrt();
- double d_dim(), exp(), r_dim(), d_int(), d_lg10(), d_mod(), d_nint(),
+ double d_dim(), exp(), r_dim(), d_int(), d_lg10(), d_mod(), d_nint(),
d_sign(), sin(), sinh(), sqrt(), tan(), tanh();
integer i_dim(), i_dnnt(), i_indx(), i_sign(), i_len();
logical l_ge(), l_gt(), l_le(), l_lt();
double r_sign();
// Local variables //
- extern // Subroutine // int fooa_(), fooc_(), food_(), fooi_(), foor_(),
+ extern // Subroutine // int fooa_(), fooc_(), food_(), fooi_(), foor_(),
fool_(), fooz_(), getem_();
static char a1[10], a2[10];
static complex c1, c2;
#define FFECOM_dimensionsMAX 7 /* Max # dimensions (quick hack). */
-#define FFECOM_targetFFE 1
-#define FFECOM_targetGCC 2
-
-#ifndef FFE_STANDALONE
-#define FFECOM_targetCURRENT FFECOM_targetGCC /* Backend! */
-#define FFECOM_ONEPASS 0
-#else
-#define FFECOM_targetCURRENT FFECOM_targetFFE
-#define FFECOM_ONEPASS 0
-#endif
-
-#if FFECOM_ONEPASS
-#define FFECOM_TWOPASS 0
-#else
-#define FFECOM_TWOPASS 1
-#endif
-
#define FFECOM_SIZE_UNIT "byte" /* Singular form. */
#define FFECOM_SIZE_UNITS "bytes" /* Plural form. */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
#define FFECOM_constantNULL NULL_TREE
#define FFECOM_nonterNULL NULL_TREE
#define FFECOM_globalNULL NULL_TREE
FFECOM_gfrt
} ffecomGfrt;
-#endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
-
/* Typedefs. */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
#ifndef TREE_CODE
#include "tree.h"
#endif
-#ifndef BUILT_FOR_270
-#ifdef DECL_STATIC_CONSTRUCTOR /* In gcc/tree.h. */
-#define BUILT_FOR_270 1
-#else
-#define BUILT_FOR_270 0
-#endif
-#endif /* !defined (BUILT_FOR_270) */
-
-#ifndef BUILT_FOR_280
-#ifdef DECL_ONE_ONLY /* In gcc/tree.h. */
-#define BUILT_FOR_280 1
-#else
-#define BUILT_FOR_280 0
-#endif
-#endif /* !defined (BUILT_FOR_280) */
-
typedef tree ffecomConstant;
#define FFECOM_constantHOOK
typedef tree ffecomNonter;
tree assign_tree; /* For ASSIGN'ed vars. */
bool addr; /* Is address of item instead of item. */
};
-#endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
/* Include files needed by this one. */
/* Global objects accessed by users of this module. */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
extern tree string_type_node;
extern tree ffecom_integer_type_node;
extern tree ffecom_integer_zero_node;
extern tree ffecom_f2c_ptr_to_ftnlen_type_node;
extern tree ffecom_f2c_ftnint_type_node;
extern tree ffecom_f2c_ptr_to_ftnint_type_node;
-#endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
/* Declare functions with prototypes. */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
tree ffecom_1 (enum tree_code code, tree type, tree node);
tree ffecom_1_fn (tree node);
tree ffecom_2 (enum tree_code code, tree type, tree node1, tree node2);
tree ffecom_const_expr (ffebld expr);
tree ffecom_decl_field (tree context, tree prevfield, const char *name,
tree type);
-#endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
void ffecom_close_include (FILE *f);
int ffecom_decode_include_option (char *spec);
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
tree ffecom_end_compstmt (void);
-#endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
void ffecom_end_transition (void);
void ffecom_exec_transition (void);
void ffecom_expand_let_stmt (ffebld dest, ffebld source);
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
tree ffecom_expr (ffebld expr);
tree ffecom_expr_assign (ffebld expr);
tree ffecom_expr_assign_w (ffebld expr);
ffetargetCharacterSize size, int elements);
tree ffecom_modify (tree newtype, tree lhs, tree rhs);
void ffecom_save_tree_forever (tree t);
-#endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
void ffecom_file (const char *name);
void ffecom_notify_init_storage (ffestorag st);
void ffecom_notify_init_symbol (ffesymbol s);
void ffecom_notify_primary_entry (ffesymbol fn);
FILE *ffecom_open_include (char *name, ffewhereLine l, ffewhereColumn c);
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
void ffecom_prepare_arg_ptr_to_expr (ffebld expr);
bool ffecom_prepare_end (void);
void ffecom_prepare_expr_ (ffebld expr, ffebld dest);
void ffecom_start_compstmt (void);
tree ffecom_start_decl (tree decl, bool is_init);
void ffecom_sym_commit (ffesymbol s);
-#endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
ffesymbol ffecom_sym_end_transition (ffesymbol s);
ffesymbol ffecom_sym_exec_transition (ffesymbol s);
ffesymbol ffecom_sym_learned (ffesymbol s);
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
void ffecom_sym_retract (ffesymbol s);
tree ffecom_temp_label (void);
tree ffecom_truth_value (tree expr);
tree ffecom_truth_value_invert (tree expr);
tree ffecom_type_expr (ffebld expr);
tree ffecom_which_entrypoint_decl (void);
-#endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
/* Define macros. */
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
-#define ffecom_expr(e) (e)
-#define ffecom_init_0()
-#define ffecom_init_2()
-#define ffecom_label_kind() FFEINFO_kindtypeINTEGERDEFAULT
-#define ffecom_pointer_kind() FFEINFO_kindtypeINTEGERDEFAULT
-#define ffecom_ptr_to_expr(e) (e)
-#define ffecom_sym_commit(s)
-#define ffecom_sym_retract(s)
-#endif /* FFECOM_targetCURRENT == FFECOM_targetFFE */
-
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
#define ffecom_f2c_typecode(bt,kt) ffecom_f2c_typecode_[(bt)][(kt)]
#define ffecom_label_kind() ffecom_label_kind_
#define ffecom_pointer_kind() ffecom_pointer_kind_
#define ffecom_prepare_expr(e) ffecom_prepare_expr_ ((e), NULL)
-#endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
#define ffecom_init_1()
#define ffecom_init_3()
ffeequiv_set_list (eq, ffebld_new_item (list, ffeequiv_list (eq)));
}
-/* ffeequiv_dump -- Dump info on equivalence object
-
- ffeequiv eq;
- ffeequiv_dump(eq); */
-
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
-void
-ffeequiv_dump (ffeequiv eq)
-{
- if (ffeequiv_common (eq) != NULL)
- fprintf (dmpout, "(common %s) ", ffesymbol_text (ffeequiv_common (eq)));
- ffebld_dump (ffeequiv_list (eq));
-}
-#endif
-
/* ffeequiv_exec_transition -- Do the hard work on all the equivalence objects
ffeequiv_exec_transition(); */
/* Declare functions with prototypes. */
void ffeequiv_add (ffeequiv eq, ffebld list, ffelexToken t);
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
-void ffeequiv_dump (ffeequiv eq);
-#endif
void ffeequiv_exec_transition (void);
void ffeequiv_init_2 (void);
void ffeequiv_kill (ffeequiv victim);
/* Define macros. */
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
-#define FFEGLOBAL_ENABLED 0
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
#define FFEGLOBAL_ENABLED 1
-#else
-#error
-#endif
#define ffeglobal_common_init(g) ((g)->tick != 0)
#define ffeglobal_common_have_pad(g) ((g)->u.common.have_pad)
/* End of #include file. */
#endif /* ! GCC_F_GLOBAL_H */
-
+
struct _ffeintrin_imp_
{
const char *const name; /* Name of implementation. */
-#if 0 /* FFECOM_targetCURRENT == FFECOM_targetGCC */
- const ffecomGfrt gfrt; /* gfrt index in library. */
-#endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
const char *const control;
};
#define DEFNAME(UPPER,LOWER,MIXED,GEN,SPEC)
#define DEFGEN(CODE,NAME,SPEC1,SPEC2)
#define DEFSPEC(CODE,NAME,CALLABLE,FAMILY,IMP)
-#if 0 /* FFECOM_targetCURRENT == FFECOM_targetGCC */
-#define DEFIMP(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL) \
- { NAME, FFECOM_gfrt ## GFRT, CONTROL },
-#define DEFIMPY(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL,Y2KBAD) \
- { NAME, FFECOM_gfrt ## GFRT, CONTROL },
-#elif 1 /* FFECOM_targetCURRENT == FFECOM_targetFFE */
#define DEFIMP(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL) \
{ NAME, CONTROL },
#define DEFIMPY(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL,Y2KBAD) \
{ NAME, CONTROL },
-#else
-#error
-#endif
#include "intrin.def"
#undef DEFNAME
#undef DEFGEN
struct _ffeintrin_imp_
{
const char *const name; /* Name of implementation. */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
const ffecomGfrt gfrt_direct;/* library routine, direct-callable form. */
const ffecomGfrt gfrt_f2c; /* library routine, f2c-callable form. */
const ffecomGfrt gfrt_gnu; /* library routine, gnu-callable form. */
-#endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
const char *const control;
const char y2kbad;
};
#define DEFNAME(UPPER,LOWER,MIXED,GEN,SPEC)
#define DEFGEN(CODE,NAME,SPEC1,SPEC2)
#define DEFSPEC(CODE,NAME,CALLABLE,FAMILY,IMP)
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
#define DEFIMP(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL) \
{ NAME, FFECOM_gfrt ## GFRTDIRECT, FFECOM_gfrt ## GFRTF2C, \
FFECOM_gfrt ## GFRTGNU, CONTROL, FALSE },
#define DEFIMPY(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL,Y2KBAD) \
{ NAME, FFECOM_gfrt ## GFRTDIRECT, FFECOM_gfrt ## GFRTF2C, \
FFECOM_gfrt ## GFRTGNU, CONTROL, Y2KBAD },
-#elif FFECOM_targetCURRENT == FFECOM_targetFFE
-#define DEFIMP(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL) \
- { NAME, CONTROL, FALSE },
-#define DEFIMPY(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL,Y2KBAD) \
- { NAME, CONTROL, Y2KBAD },
-#else
-#error
-#endif
#include "intrin.def"
#undef DEFNAME
#undef DEFGEN
if (ffe_is_f2c ())
gfrt = ffeintrin_imps_[imp].gfrt_f2c;
- else
+ else
gfrt = ffeintrin_imps_[imp].gfrt_gnu;
assert (gfrt != FFECOM_gfrt);
/* Return run-time index of intrinsic implementation as direct call. */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
ffecomGfrt
ffeintrin_gfrt_direct (ffeintrinImp imp)
{
return ffeintrin_imps_[imp].gfrt_direct;
}
-#endif
/* Return run-time index of intrinsic implementation as actual argument. */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
ffecomGfrt
ffeintrin_gfrt_indirect (ffeintrinImp imp)
{
return ffeintrin_imps_[imp].gfrt_gnu;
return ffeintrin_imps_[imp].gfrt_f2c;
}
-#endif
void
ffeintrin_init_0 ()
state = ffeintrin_state_family (ffeintrin_specs_[spec].family);
return (!ffe_is_pedantic () || ffeintrin_specs_[spec].is_actualarg)
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
&& (ffe_is_f2c ()
? (ffeintrin_imps_[ffeintrin_specs_[spec].implementation].gfrt_f2c
!= FFECOM_gfrt)
: (ffeintrin_imps_[ffeintrin_specs_[spec].implementation].gfrt_gnu
!= FFECOM_gfrt))
-#endif
&& ((state == FFE_intrinsicstateENABLED)
|| (state == FFE_intrinsicstateHIDDEN));
}
void ffeintrin_fulfill_generic (ffebld *expr, ffeinfo *info, ffelexToken t);
void ffeintrin_fulfill_specific (ffebld *expr, ffeinfo *info,
bool *check_intrin, ffelexToken t);
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
ffecomGfrt ffeintrin_gfrt_direct (ffeintrinImp imp);
ffecomGfrt ffeintrin_gfrt_indirect (ffeintrinImp imp);
-#endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
void ffeintrin_init_0 (void);
#define ffeintrin_init_1()
#define ffeintrin_init_2()
#include "malloc.h"
#include "src.h"
#include "debug.h"
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
#include "flags.h"
#include "input.h"
#include "toplev.h"
#include "output.h"
#include "ggc.h"
-#endif
static void ffelex_append_to_token_ (char c);
static int ffelex_backslash_ (int c, ffewhereColumnNumber col);
static void ffelex_bad_here_ (int num, ffewhereLineNumber ln0,
ffewhereColumnNumber cn0);
static void ffelex_finish_statement_ (void);
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
static int ffelex_get_directive_line_ (char **text, FILE *finput);
static int ffelex_hash_ (FILE *f);
-#endif
static ffewhereColumnNumber ffelex_image_char_ (int c,
ffewhereColumnNumber col);
static void ffelex_include_ (void);
ffewhere_column_kill (wc0);
}
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
static int
ffelex_getc_ (FILE *finput)
{
return getc (finput);
}
-#endif
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
static int
ffelex_cfebackslash_ (int *use_d, int *d, FILE *finput)
{
return c;
}
-#endif
/* A miniature version of the C front-end lexer. */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
static int
ffelex_cfelex_ (ffelexToken *xtoken, FILE *finput, int c)
{
*xtoken = token;
return c;
}
-#endif
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
static void
ffelex_file_pop_ (const char *input_filename)
{
input_file_stack->name = input_filename;
}
-#endif
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
static void
ffelex_file_push_ (int old_lineno, const char *input_filename)
{
if (input_file_stack)
input_file_stack->name = input_filename;
}
-#endif
/* Prepare to finish a statement-in-progress by sending the current
token, if any, then setting up EOS as the current token with the
/* Copied from gcc/c-common.c get_directive_line. */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
static int
ffelex_get_directive_line_ (char **text, FILE *finput)
{
char_escaped = (c == '\\' && ! char_escaped);
}
}
-#endif
/* Handle # directives that make it through (or are generated by) the
preprocessor. As much as reasonably possible, emulate the behavior
Returns the next character unhandled, which is always newline or EOF. */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
-
#if defined HANDLE_PRAGMA
/* Local versions of these macros, that can be passed as function pointers. */
static int
ISSPACE() may evaluate its argument more than once! */
while (((c = getc (finput)), ISSPACE(c)))
continue;
-
+
do
{
* buff ++ = c;
&& buff < buffer + 128);
pragma_ungetc (c);
-
+
* -- buff = 0;
#ifdef HANDLE_PRAGMA
if (HANDLE_PRAGMA (pragma_getc, pragma_ungetc, buffer))
;
return c;
}
-#endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
/* "Image" a character onto the card image, return incremented column number.
ffewhereLineNumber linecount_current = ffelex_linecount_current_;
ffewhereLineNumber linecount_offset
= ffewhere_line_filelinenum (current_wl);
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
int old_lineno = lineno;
const char *old_input_filename = input_filename;
-#endif
if (card_length != 0)
{
ffewhere_file_set (include_wherefile, TRUE, 0);
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
ffelex_file_push_ (old_lineno, ffewhere_file_name (include_wherefile));
-#endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
if (ffelex_include_free_form_)
ffelex_file_free (include_wherefile, include_file);
else
ffelex_file_fixed (include_wherefile, include_file);
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
ffelex_file_pop_ (ffewhere_file_name (current_wf));
-#endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
ffewhere_file_set (current_wf, TRUE, linecount_offset);
}
ffelex_card_image_[card_length] = '\0';
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
input_filename = old_input_filename;
lineno = old_lineno;
-#endif
ffelex_linecount_current_ = linecount_current;
ffelex_current_wf_ = current_wf;
ffelex_final_nontab_column_ = final_nontab_column;
{
ffelex_linecount_current_ = ffelex_linecount_next_;
++ffelex_linecount_next_;
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
++lineno;
-#endif
}
static void
assert (ffelex_handler_ != NULL);
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
lineno = 0;
input_filename = ffewhere_file_name (wf);
-#endif
ffelex_current_wf_ = wf;
disallow_continuation_line = TRUE;
ignore_disallowed_continuation = FALSE;
while ((c != '\n') && (c != EOF))
c = getc (f);
}
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
else if (lextype == FFELEX_typeHASH)
c = ffelex_hash_ (f);
-#endif
else if (lextype == FFELEX_typeSLASH)
{
/* SIDE-EFFECT ABOVE HAS HAPPENED. */
assert (ffelex_handler_ != NULL);
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
lineno = 0;
input_filename = ffewhere_file_name (wf);
-#endif
ffelex_current_wf_ = wf;
continuation_line = FALSE;
ffelex_token_->type = FFELEX_typeNONE;
|| (c == '#'))
{
if (c == '#')
- {
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
- c = ffelex_hash_ (f);
-#else
- /* Don't skip over # line after all. */
- break;
-#endif
- }
+ c = ffelex_hash_ (f);
comment_line: /* :::::::::::::::::::: */
/* See the code in com.c that calls this to understand why. */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
void
ffelex_hash_kludge (FILE *finput)
{
}
}
-#endif
void
ffelex_init_1 ()
{
#include "com.h"
#include "where.h"
#include "version.h"
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
#include "flags.h"
-#endif
#define NAME_OF_STDIN "<stdin>"
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
-void
-main (int argc, char *argv[])
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
extern FILE *finput;
int
yyparse ()
-#else
-#error
-#endif
{
ffewhereFile wf;
if (ffe_is_version ())
fprintf (stderr, "GNU Fortran Front End version %s\n", ffe_version_string);
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- ffe_init_0 ();
-
- {
- int strings_processed;
- for (--argc, ++argv; argc > 0; argc -= strings_processed, argv += strings_processed)
- {
- strings_processed = ffe_decode_option (argc, argv);
- if (strings_processed == 0)
- {
- fprintf (stderr, "Unrecognized option: %s\n", argv[0]);
- strings_processed = 1;
- }
- }
- }
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
if (!ffe_is_pedantic ())
ffe_set_is_pedantic (pedantic);
-#else
-#error
-#endif
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- wf = ffewhere_file_new (NAME_OF_STDIN, strlen (NAME_OF_STDIN));
- ffecom_file (NAME_OF_STDIN);
- ffe_file (wf, stdin);
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
wf = ffewhere_file_new (main_input_filename, strlen (main_input_filename));
ffecom_file (main_input_filename);
ffe_file (wf, finput);
-#else
-#error
-#endif
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
ffecom_finish_compile ();
return 0;
-#elif FFECOM_targetCURRENT == FFECOM_targetFFE
- ffe_terminate_0 ();
-
- exit (0);
-#else
-#error
-#endif
}
if (ffe_is_ffedebug ())
{
ffestorag_report ();
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- ffesymbol_report_all ();
-#endif
}
}
if (ffe_is_ffedebug ())
{
ffestorag_report ();
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- ffesymbol_report_all ();
-#endif
}
ffelex_set_names (TRUE);
FFESTD_
} ffestdStatelet_;
-#if FFECOM_TWOPASS
typedef enum
{
FFESTD_stmtidENDDOLOOP_,
FFESTD_stmtid_,
} ffestdStmtId_;
-#endif
-
/* Internal typedefs. */
typedef struct _ffestd_expr_item_ *ffestdExprItem_;
-#if FFECOM_TWOPASS
typedef struct _ffestd_stmt_ *ffestdStmt_;
-#endif
/* Private include files. */
ffelexToken token;
};
-#if FFECOM_TWOPASS
struct _ffestd_stmt_
{
ffestdStmt_ next;
ffestdStmt_ previous;
ffestdStmtId_ id;
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
char *filename;
int filelinenum;
-#endif
union
{
struct
u;
};
-#endif
-
/* Static objects accessed by functions in this module. */
static ffestdStatelet_ ffestd_statelet_ = FFESTD_stateletSIMPLE_;
static int ffestd_block_level_ = 0; /* Block level for reachableness. */
static bool ffestd_is_reachable_; /* Is the current stmt reachable? */
static ffelab ffestd_label_formatdef_ = NULL;
-#if FFECOM_TWOPASS
static ffestdExprItem_ *ffestd_expr_list_;
static struct
{
ffestdStmt_ first;
ffestdStmt_ last;
}
-
-ffestd_stmt_list_
-=
+ffestd_stmt_list_ =
{
NULL, NULL
};
-#endif
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
-static int ffestd_2pass_entrypoints_ = 0; /* # ENTRY statements
- pending. */
-#endif
+
+/* # ENTRY statements pending. */
+static int ffestd_2pass_entrypoints_ = 0;
/* Static functions (internal). */
-#if FFECOM_TWOPASS
static void ffestd_stmt_append_ (ffestdStmt_ stmt);
static ffestdStmt_ ffestd_stmt_new_ (ffestdStmtId_ id);
static void ffestd_stmt_pass_ (void);
-#endif
-#if FFESTD_COPY_EASY_ && FFECOM_TWOPASS
+#if FFESTD_COPY_EASY_
static ffestpInquireStmt *ffestd_subr_copy_easy_ (ffestpInquireIx max);
#endif
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
static void ffestd_subr_vxt_ (void);
-#endif
#if FFESTR_F90
static void ffestd_subr_f90_ (void);
#endif
/* Internal macros. */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
#define ffestd_subr_line_now_() \
ffeste_set_line (ffelex_token_where_filename (ffesta_tokens[0]), \
ffelex_token_where_filelinenum (ffesta_tokens[0]))
#define ffestd_subr_line_save_(s) \
((s)->filename = ffelex_token_where_filename (ffesta_tokens[0]), \
(s)->filelinenum = ffelex_token_where_filelinenum (ffesta_tokens[0]))
-#else
-#define ffestd_subr_line_now_()
-#if FFECOM_TWOPASS
-#define ffestd_subr_line_restore_(s)
-#define ffestd_subr_line_save_(s)
-#endif /* FFECOM_TWOPASS */
-#endif /* FFECOM_targetCURRENT != FFECOM_targetGCC */
#define ffestd_check_simple_() \
assert(ffestd_statelet_ == FFESTD_stateletSIMPLE_)
#define ffestd_check_start_() \
|| ffestd_statelet_ == FFESTD_stateletITEM_); \
ffestd_statelet_ = FFESTD_stateletSIMPLE_
-#if FFESTD_COPY_EASY_ && FFECOM_TWOPASS
+#if FFESTD_COPY_EASY_
#define ffestd_subr_copy_accept_() (ffestpAcceptStmt *) \
ffestd_subr_copy_easy_((ffestpInquireIx) FFESTP_acceptix)
#define ffestd_subr_copy_beru_() (ffestpBeruStmt *) \
ffestd_stmt_append_(ffestd_stmt_new_(FFESTD_stmtidR737A_)); */
-#if FFECOM_TWOPASS
static void
ffestd_stmt_append_ (ffestdStmt_ stmt)
{
stmt->previous->next = stmt;
}
-#endif
/* ffestd_stmt_new_ -- Make new statement with given id
ffestdStmt_ stmt;
stmt = ffestd_stmt_new_(FFESTD_stmtidR737A_); */
-#if FFECOM_TWOPASS
static ffestdStmt_
ffestd_stmt_new_ (ffestdStmtId_ id)
{
return stmt;
}
-#endif
/* ffestd_stmt_pass_ -- Pass all statements on list to ffeste
ffestd_stmt_pass_(); */
-#if FFECOM_TWOPASS
static void
ffestd_stmt_pass_ ()
{
ffestdExprItem_ expr; /* For traversing lists. */
bool okay = (TREE_CODE (current_function_decl) != ERROR_MARK);
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
if ((ffestd_2pass_entrypoints_ != 0) && okay)
{
tree which = ffecom_which_entrypoint_decl ();
expand_end_case (which);
}
-#endif
for (stmt = ffestd_stmt_list_.first;
stmt != (ffestdStmt_) &ffestd_stmt_list_.first;
}
}
-#endif
/* ffestd_subr_copy_easy_ -- Copy I/O statement data structure
ffestd_subr_copy_easy_();
and structure references assume (though not necessarily dangerous if
FALSE) that INQUIRE has the most file elements. */
-#if FFESTD_COPY_EASY_ && FFECOM_TWOPASS
+#if FFESTD_COPY_EASY_
static ffestpInquireStmt *
ffestd_subr_copy_easy_ (ffestpInquireIx max)
{
ffestd_subr_vxt_(); */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
static void
ffestd_subr_vxt_ ()
{
ffebad_finish ();
}
-#endif
/* ffestd_begin_uses -- Start a bunch of USE statements
ffestd_begin_uses();
void
ffestd_begin_uses ()
{
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- fputs ("; begin_uses\n", dmpout);
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
-#else
-#error
-#endif
}
/* ffestd_do -- End of statement following DO-term-stmt etc
void
ffestd_do (bool ok UNUSED)
{
-#if FFECOM_ONEPASS
- ffestd_subr_line_now_ ();
- ffeste_do (ffestw_stack_top ());
-#else
- {
- ffestdStmt_ stmt;
+ ffestdStmt_ stmt;
- stmt = ffestd_stmt_new_ (FFESTD_stmtidENDDOLOOP_);
- ffestd_stmt_append_ (stmt);
- ffestd_subr_line_save_ (stmt);
- stmt->u.enddoloop.block = ffestw_stack_top ();
- }
-#endif
+ stmt = ffestd_stmt_new_ (FFESTD_stmtidENDDOLOOP_);
+ ffestd_stmt_append_ (stmt);
+ ffestd_subr_line_save_ (stmt);
+ stmt->u.enddoloop.block = ffestw_stack_top ();
--ffestd_block_level_;
assert (ffestd_block_level_ >= 0);
void
ffestd_end_uses (bool ok)
{
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- fputs ("; end_uses\n", dmpout);
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
-#else
-#error
-#endif
}
/* ffestd_end_R740 -- End a WHERE(-THEN)
void
ffestd_end_R807 (bool ok UNUSED)
{
-#if FFECOM_ONEPASS
- ffestd_subr_line_now_ ();
- ffeste_end_R807 ();
-#else
- {
- ffestdStmt_ stmt;
+ ffestdStmt_ stmt;
- stmt = ffestd_stmt_new_ (FFESTD_stmtidENDLOGIF_);
- ffestd_stmt_append_ (stmt);
- ffestd_subr_line_save_ (stmt);
- }
-#endif
+ stmt = ffestd_stmt_new_ (FFESTD_stmtidENDLOGIF_);
+ ffestd_stmt_append_ (stmt);
+ ffestd_subr_line_save_ (stmt);
--ffestd_block_level_;
assert (ffestd_block_level_ >= 0);
{
ffecom_exec_transition ();
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- fputs ("{ begin_exec\n", dmpout);
-#endif
-
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
if (ffestd_2pass_entrypoints_ != 0)
{ /* Process pending ENTRY statements now that
info filled in. */
}
while (--ents != 0);
}
-#endif
}
/* ffestd_exec_end -- Executable statements can no longer come in now
void
ffestd_exec_end ()
{
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
int old_lineno = lineno;
const char *old_input_filename = input_filename;
-#endif
ffecom_end_transition ();
-#if FFECOM_TWOPASS
ffestd_stmt_pass_ ();
-#endif
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- fputs ("} end_exec\n", dmpout);
- fputs ("> end_unit\n", dmpout);
-#endif
-
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
ffecom_finish_progunit ();
if (ffestd_2pass_entrypoints_ != 0)
lineno = old_lineno;
input_filename = old_input_filename;
-#endif
}
/* ffestd_init_3 -- Initialize for any program unit
void
ffestd_init_3 ()
{
-#if FFECOM_TWOPASS
ffestd_stmt_list_.first = (ffestdStmt_) &ffestd_stmt_list_.first;
ffestd_stmt_list_.last = (ffestdStmt_) &ffestd_stmt_list_.first;
-#endif
}
/* Generate "code" for "any" label def. */
void
ffestd_labeldef_any (ffelab label UNUSED)
{
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- fprintf (dmpout, "; any_label_def %lu\n", ffelab_value (label));
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
-#else
-#error
-#endif
}
/* ffestd_labeldef_branch -- Generate "code" for branch label def
void
ffestd_labeldef_branch (ffelab label)
{
-#if FFECOM_ONEPASS
- ffeste_labeldef_branch (label);
-#else
- {
- ffestdStmt_ stmt;
+ ffestdStmt_ stmt;
- stmt = ffestd_stmt_new_ (FFESTD_stmtidEXECLABEL_);
- ffestd_stmt_append_ (stmt);
- stmt->u.execlabel.label = label;
- }
-#endif
+ stmt = ffestd_stmt_new_ (FFESTD_stmtidEXECLABEL_);
+ ffestd_stmt_append_ (stmt);
+ stmt->u.execlabel.label = label;
ffestd_is_reachable_ = TRUE;
}
{
ffestd_label_formatdef_ = label;
-#if FFECOM_ONEPASS
- ffeste_labeldef_format (label);
-#else
- {
- ffestdStmt_ stmt;
+ ffestdStmt_ stmt;
- stmt = ffestd_stmt_new_ (FFESTD_stmtidFORMATLABEL_);
-#if 0
- /* Don't bother with this. See FORMAT statement. */
- /* Prepend FORMAT label instead of appending it, so all the
- FORMAT label/statement pairs end up at the top of the list.
- This helps ensure all decls for a block (in the GBE) are
- known before any executable statements are generated. */
- stmt->previous = (ffestdStmt_) &ffestd_stmt_list_.first;
- stmt->next = ffestd_stmt_list_.first;
- stmt->next->previous = stmt;
- stmt->previous->next = stmt;
-#else
- ffestd_stmt_append_ (stmt);
-#endif
- stmt->u.formatlabel.label = label;
- }
-#endif
+ stmt = ffestd_stmt_new_ (FFESTD_stmtidFORMATLABEL_);
+ ffestd_stmt_append_ (stmt);
+ stmt->u.formatlabel.label = label;
}
/* ffestd_labeldef_useless -- Generate "code" for useless label def
void
ffestd_labeldef_useless (ffelab label UNUSED)
{
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- fprintf (dmpout, "; useless_label_def %lu\n", ffelab_value (label));
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
-#else
-#error
-#endif
}
/* ffestd_R423A -- PRIVATE statement (in R422 derived-type statement)
ffestd_R423A ()
{
ffestd_check_simple_ ();
-
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- fputs ("* PRIVATE_derived_type\n", dmpout);
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
-#else
-#error
-#endif
}
/* ffestd_R423B -- SEQUENCE statement (in R422 derived-type-stmt)
ffestd_R423B ()
{
ffestd_check_simple_ ();
-
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- fputs ("* SEQUENCE_derived_type\n", dmpout);
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
-#else
-#error
-#endif
}
/* ffestd_R424 -- derived-TYPE-def statement
void
ffestd_R425 (bool ok)
{
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- fprintf (dmpout, "* END_TYPE %s\n", ffelex_token_text (ffestw_name (ffestw_stack_top ())));
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
-#else
-#error
-#endif
}
/* ffestd_R519_start -- INTENT statement list begin
ffestd_R522 ()
{
ffestd_check_simple_ ();
-
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- fputs ("* SAVE_all\n", dmpout);
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
-#else
-#error
-#endif
}
/* ffestd_R522start -- SAVE statement list begin
ffestd_R522start ()
{
ffestd_check_start_ ();
-
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- fputs ("* SAVE ", dmpout);
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
-#else
-#error
-#endif
}
/* ffestd_R522item_object -- SAVE statement for object-name
ffestd_R522item_object (ffelexToken name UNUSED)
{
ffestd_check_item_ ();
-
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- fprintf (dmpout, "%s,", ffelex_token_text (name));
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
-#else
-#error
-#endif
}
/* ffestd_R522item_cblock -- SAVE statement for common-block-name
ffestd_R522item_cblock (ffelexToken name UNUSED)
{
ffestd_check_item_ ();
-
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- fprintf (dmpout, "/%s/,", ffelex_token_text (name));
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
-#else
-#error
-#endif
}
/* ffestd_R522finish -- SAVE statement list complete
ffestd_R522finish ()
{
ffestd_check_finish_ ();
-
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- fputc ('\n', dmpout);
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
-#else
-#error
-#endif
}
/* ffestd_R524_start -- DIMENSION statement list begin
ffestd_R524_start (bool virtual UNUSED)
{
ffestd_check_start_ ();
-
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- if (virtual)
- fputs ("* VIRTUAL ", dmpout); /* V028. */
- else
- fputs ("* DIMENSION ", dmpout);
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
-#else
-#error
-#endif
}
/* ffestd_R524_item -- DIMENSION statement for object-name
ffestd_R524_item (ffelexToken name UNUSED, ffesttDimList dims UNUSED)
{
ffestd_check_item_ ();
-
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- fputs (ffelex_token_text (name), dmpout);
- fputc ('(', dmpout);
- ffestt_dimlist_dump (dims);
- fputs ("),", dmpout);
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
-#else
-#error
-#endif
}
/* ffestd_R524_finish -- DIMENSION statement list complete
ffestd_R524_finish ()
{
ffestd_check_finish_ ();
-
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- fputc ('\n', dmpout);
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
-#else
-#error
-#endif
}
/* ffestd_R525_start -- ALLOCATABLE statement list begin
ffestd_R537_start ()
{
ffestd_check_start_ ();
-
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- fputs ("* PARAMETER (", dmpout);
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
-#else
-#error
-#endif
}
/* ffestd_R537_item -- PARAMETER statement assignment
ffestd_R537_item (ffebld dest UNUSED, ffebld source UNUSED)
{
ffestd_check_item_ ();
-
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- ffebld_dump (dest);
- fputc ('=', dmpout);
- ffebld_dump (source);
- fputc (',', dmpout);
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
-#else
-#error
-#endif
}
/* ffestd_R537_finish -- PARAMETER statement list complete
ffestd_R537_finish ()
{
ffestd_check_finish_ ();
-
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- fputs (")\n", dmpout);
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
-#else
-#error
-#endif
}
/* ffestd_R539 -- IMPLICIT NONE statement
ffestd_R539 ()
{
ffestd_check_simple_ ();
-
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- fputs ("* IMPLICIT_NONE\n", dmpout);
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
-#else
-#error
-#endif
}
/* ffestd_R539start -- IMPLICIT statement
ffestd_R539start ()
{
ffestd_check_start_ ();
-
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- fputs ("* IMPLICIT ", dmpout);
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
-#else
-#error
-#endif
}
/* ffestd_R539item -- IMPLICIT statement specification (R540)
ffelexToken kindt UNUSED, ffebld len UNUSED,
ffelexToken lent UNUSED, ffesttImpList letters UNUSED)
{
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- char *a;
-#endif
-
ffestd_check_item_ ();
-
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- switch (type)
- {
- case FFESTP_typeINTEGER:
- a = "INTEGER";
- break;
-
- case FFESTP_typeBYTE:
- a = "BYTE";
- break;
-
- case FFESTP_typeWORD:
- a = "WORD";
- break;
-
- case FFESTP_typeREAL:
- a = "REAL";
- break;
-
- case FFESTP_typeCOMPLEX:
- a = "COMPLEX";
- break;
-
- case FFESTP_typeLOGICAL:
- a = "LOGICAL";
- break;
-
- case FFESTP_typeCHARACTER:
- a = "CHARACTER";
- break;
-
- case FFESTP_typeDBLPRCSN:
- a = "DOUBLE PRECISION";
- break;
-
- case FFESTP_typeDBLCMPLX:
- a = "DOUBLE COMPLEX";
- break;
-
-#if FFESTR_F90
- case FFESTP_typeTYPE:
- a = "TYPE";
- break;
-#endif
-
- default:
- assert (FALSE);
- a = "?";
- break;
- }
- fprintf (dmpout, "%s(", a);
- if (kindt != NULL)
- {
- fputs ("kind=", dmpout);
- if (kind == NULL)
- fputs (ffelex_token_text (kindt), dmpout);
- else
- ffebld_dump (kind);
- if (lent != NULL)
- fputc (',', dmpout);
- }
- if (lent != NULL)
- {
- fputs ("len=", dmpout);
- if (len == NULL)
- fputs (ffelex_token_text (lent), dmpout);
- else
- ffebld_dump (len);
- }
- fputs (")(", dmpout);
- ffestt_implist_dump (letters);
- fputs ("),", dmpout);
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
-#else
-#error
-#endif
}
/* ffestd_R539finish -- IMPLICIT statement
ffestd_R539finish ()
{
ffestd_check_finish_ ();
-
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- fputc ('\n', dmpout);
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
-#else
-#error
-#endif
}
/* ffestd_R542_start -- NAMELIST statement list begin
ffestd_R542_start ()
{
ffestd_check_start_ ();
-
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- fputs ("* NAMELIST ", dmpout);
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
-#else
-#error
-#endif
}
/* ffestd_R542_item_nlist -- NAMELIST statement for group-name
ffestd_R542_item_nlist (ffelexToken name UNUSED)
{
ffestd_check_item_ ();
-
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- fprintf (dmpout, "/%s/", ffelex_token_text (name));
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
-#else
-#error
-#endif
}
/* ffestd_R542_item_nitem -- NAMELIST statement for variable-name
ffestd_R542_item_nitem (ffelexToken name UNUSED)
{
ffestd_check_item_ ();
-
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- fprintf (dmpout, "%s,", ffelex_token_text (name));
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
-#else
-#error
-#endif
}
/* ffestd_R542_finish -- NAMELIST statement list complete
ffestd_R542_finish ()
{
ffestd_check_finish_ ();
-
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- fputc ('\n', dmpout);
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
-#else
-#error
-#endif
}
/* ffestd_R544_start -- EQUIVALENCE statement list begin
ffestd_R544_start ()
{
ffestd_check_start_ ();
-
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- fputs ("* EQUIVALENCE (", dmpout);
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
-#else
-#error
-#endif
}
#endif
ffestd_R544_item (ffesttExprList exprlist)
{
ffestd_check_item_ ();
-
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- ffestt_exprlist_dump (exprlist);
- fputs ("),", dmpout);
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
-#else
-#error
-#endif
}
#endif
ffestd_R544_finish ()
{
ffestd_check_finish_ ();
-
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- fputs (")\n", dmpout);
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
-#else
-#error
-#endif
}
#endif
ffestd_R547_start ()
{
ffestd_check_start_ ();
-
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- fputs ("* COMMON ", dmpout);
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
-#else
-#error
-#endif
}
/* ffestd_R547_item_object -- COMMON statement for object-name
ffesttDimList dims UNUSED)
{
ffestd_check_item_ ();
-
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- fputs (ffelex_token_text (name), dmpout);
- if (dims != NULL)
- {
- fputc ('(', dmpout);
- ffestt_dimlist_dump (dims);
- fputc (')', dmpout);
- }
- fputc (',', dmpout);
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
-#else
-#error
-#endif
}
/* ffestd_R547_item_cblock -- COMMON statement for common-block-name
ffestd_R547_item_cblock (ffelexToken name UNUSED)
{
ffestd_check_item_ ();
-
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- if (name == NULL)
- fputs ("//,", dmpout);
- else
- fprintf (dmpout, "/%s/,", ffelex_token_text (name));
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
-#else
-#error
-#endif
}
/* ffestd_R547_finish -- COMMON statement list complete
ffestd_R547_finish ()
{
ffestd_check_finish_ ();
-
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- fputc ('\n', dmpout);
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
-#else
-#error
-#endif
}
/* ffestd_R620 -- ALLOCATE statement
ffestd_check_simple_ ();
ffestd_subr_f90_ ();
- return;
-
-#ifdef FFESTD_F90
- fputs ("+ ALLOCATE (", dmpout);
- ffestt_exprlist_dump (exprlist);
- if (stat != NULL)
- {
- fputs (",stat=", dmpout);
- ffebld_dump (stat);
- }
- fputs (")\n", dmpout);
-#endif
}
/* ffestd_R624 -- NULLIFY statement
ffestd_check_simple_ ();
ffestd_subr_f90_ ();
- return;
-
-#ifdef FFESTD_F90
- fputs ("+ DEALLOCATE (", dmpout);
- ffestt_exprlist_dump (exprlist);
- if (stat != NULL)
- {
- fputs (",stat=", dmpout);
- ffebld_dump (stat);
- }
- fputs (")\n", dmpout);
-#endif
}
#endif
{
ffestd_check_simple_ ();
-#if FFECOM_ONEPASS
- ffestd_subr_line_now_ ();
- ffeste_R737A (dest, source);
-#else
- {
- ffestdStmt_ stmt;
-
- stmt = ffestd_stmt_new_ (FFESTD_stmtidR737A_);
- ffestd_stmt_append_ (stmt);
- ffestd_subr_line_save_ (stmt);
- stmt->u.R737A.pool = ffesta_output_pool;
- stmt->u.R737A.dest = dest;
- stmt->u.R737A.source = source;
- ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
- }
-#endif
+ ffestdStmt_ stmt;
+
+ stmt = ffestd_stmt_new_ (FFESTD_stmtidR737A_);
+ ffestd_stmt_append_ (stmt);
+ ffestd_subr_line_save_ (stmt);
+ stmt->u.R737A.pool = ffesta_output_pool;
+ stmt->u.R737A.dest = dest;
+ stmt->u.R737A.source = source;
+ ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
}
/* ffestd_R737B -- Assignment statement inside of WHERE
ffestd_R737B (ffebld dest, ffebld source)
{
ffestd_check_simple_ ();
-
- return; /* F90. */
-
-#ifdef FFESTD_F90
- fputs ("+ let_inside_where ", dmpout);
- ffebld_dump (dest);
- fputs ("=", dmpout);
- ffebld_dump (source);
- fputc ('\n', dmpout);
-#endif
}
/* ffestd_R738 -- Pointer assignment statement
ffestd_check_simple_ ();
ffestd_subr_f90_ ();
- return;
-
-#ifdef FFESTD_F90
- fputs ("+ let_pointer ", dmpout);
- ffebld_dump (dest);
- fputs ("=>", dmpout);
- ffebld_dump (source);
- fputc ('\n', dmpout);
-#endif
}
/* ffestd_R740 -- WHERE statement
ffestd_check_simple_ ();
ffestd_subr_f90_ ();
- return;
-
-#ifdef FFESTD_F90
- fputs ("+ WHERE (", dmpout);
- ffebld_dump (expr);
- fputs (")\n", dmpout);
-
- ++ffestd_block_level_;
- assert (ffestd_block_level_ > 0);
-#endif
}
/* ffestd_R742 -- WHERE-construct statement
ffestd_check_simple_ ();
ffestd_subr_f90_ ();
- return;
-
-#ifdef FFESTD_F90
- fputs ("+ WHERE_construct (", dmpout);
- ffebld_dump (expr);
- fputs (")\n", dmpout);
-
- ++ffestd_block_level_;
- assert (ffestd_block_level_ > 0);
-#endif
}
/* ffestd_R744 -- ELSE WHERE statement
void
ffestd_R803 (ffelexToken construct_name UNUSED, ffebld expr)
{
+ ffestdStmt_ stmt;
+
ffestd_check_simple_ ();
-#if FFECOM_ONEPASS
- ffestd_subr_line_now_ ();
- ffeste_R803 (expr); /* Don't bother with name. */
-#else
- {
- ffestdStmt_ stmt;
-
- stmt = ffestd_stmt_new_ (FFESTD_stmtidR803_);
- ffestd_stmt_append_ (stmt);
- ffestd_subr_line_save_ (stmt);
- stmt->u.R803.pool = ffesta_output_pool;
- stmt->u.R803.block = ffestw_use (ffestw_stack_top ());
- stmt->u.R803.expr = expr;
- ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
- }
-#endif
+ stmt = ffestd_stmt_new_ (FFESTD_stmtidR803_);
+ ffestd_stmt_append_ (stmt);
+ ffestd_subr_line_save_ (stmt);
+ stmt->u.R803.pool = ffesta_output_pool;
+ stmt->u.R803.block = ffestw_use (ffestw_stack_top ());
+ stmt->u.R803.expr = expr;
+ ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
++ffestd_block_level_;
assert (ffestd_block_level_ > 0);
void
ffestd_R804 (ffebld expr, ffelexToken name UNUSED)
{
+ ffestdStmt_ stmt;
+
ffestd_check_simple_ ();
-#if FFECOM_ONEPASS
- ffestd_subr_line_now_ ();
- ffeste_R804 (expr); /* Don't bother with name. */
-#else
- {
- ffestdStmt_ stmt;
-
- stmt = ffestd_stmt_new_ (FFESTD_stmtidR804_);
- ffestd_stmt_append_ (stmt);
- ffestd_subr_line_save_ (stmt);
- stmt->u.R804.pool = ffesta_output_pool;
- stmt->u.R804.block = ffestw_use (ffestw_stack_top ());
- stmt->u.R804.expr = expr;
- ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
- }
-#endif
+ stmt = ffestd_stmt_new_ (FFESTD_stmtidR804_);
+ ffestd_stmt_append_ (stmt);
+ ffestd_subr_line_save_ (stmt);
+ stmt->u.R804.pool = ffesta_output_pool;
+ stmt->u.R804.block = ffestw_use (ffestw_stack_top ());
+ stmt->u.R804.expr = expr;
+ ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
}
/* ELSE statement. */
void
ffestd_R805 (ffelexToken name UNUSED)
{
- ffestd_check_simple_ ();
+ ffestdStmt_ stmt;
-#if FFECOM_ONEPASS
- ffestd_subr_line_now_ ();
- ffeste_R805 (); /* Don't bother with name. */
-#else
- {
- ffestdStmt_ stmt;
+ ffestd_check_simple_ ();
- stmt = ffestd_stmt_new_ (FFESTD_stmtidR805_);
- ffestd_stmt_append_ (stmt);
- ffestd_subr_line_save_ (stmt);
- stmt->u.R805.block = ffestw_use (ffestw_stack_top ());
- }
-#endif
+ stmt = ffestd_stmt_new_ (FFESTD_stmtidR805_);
+ ffestd_stmt_append_ (stmt);
+ ffestd_subr_line_save_ (stmt);
+ stmt->u.R805.block = ffestw_use (ffestw_stack_top ());
}
/* END IF statement. */
void
ffestd_R806 (bool ok UNUSED)
{
-#if FFECOM_ONEPASS
- ffestd_subr_line_now_ ();
- ffeste_R806 ();
-#else
- {
- ffestdStmt_ stmt;
+ ffestdStmt_ stmt;
- stmt = ffestd_stmt_new_ (FFESTD_stmtidR806_);
- ffestd_stmt_append_ (stmt);
- ffestd_subr_line_save_ (stmt);
- stmt->u.R806.block = ffestw_use (ffestw_stack_top ());
- }
-#endif
+ stmt = ffestd_stmt_new_ (FFESTD_stmtidR806_);
+ ffestd_stmt_append_ (stmt);
+ ffestd_subr_line_save_ (stmt);
+ stmt->u.R806.block = ffestw_use (ffestw_stack_top ());
--ffestd_block_level_;
assert (ffestd_block_level_ >= 0);
void
ffestd_R807 (ffebld expr)
{
+ ffestdStmt_ stmt;
+
ffestd_check_simple_ ();
-#if FFECOM_ONEPASS
- ffestd_subr_line_now_ ();
- ffeste_R807 (expr);
-#else
- {
- ffestdStmt_ stmt;
-
- stmt = ffestd_stmt_new_ (FFESTD_stmtidR807_);
- ffestd_stmt_append_ (stmt);
- ffestd_subr_line_save_ (stmt);
- stmt->u.R807.pool = ffesta_output_pool;
- stmt->u.R807.expr = expr;
- ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
- }
-#endif
+ stmt = ffestd_stmt_new_ (FFESTD_stmtidR807_);
+ ffestd_stmt_append_ (stmt);
+ ffestd_subr_line_save_ (stmt);
+ stmt->u.R807.pool = ffesta_output_pool;
+ stmt->u.R807.expr = expr;
+ ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
++ffestd_block_level_;
assert (ffestd_block_level_ > 0);
void
ffestd_R809 (ffelexToken construct_name UNUSED, ffebld expr)
{
+ ffestdStmt_ stmt;
+
ffestd_check_simple_ ();
-#if FFECOM_ONEPASS
- ffestd_subr_line_now_ ();
- ffeste_R809 (ffestw_stack_top (), expr);
-#else
- {
- ffestdStmt_ stmt;
-
- stmt = ffestd_stmt_new_ (FFESTD_stmtidR809_);
- ffestd_stmt_append_ (stmt);
- ffestd_subr_line_save_ (stmt);
- stmt->u.R809.pool = ffesta_output_pool;
- stmt->u.R809.block = ffestw_use (ffestw_stack_top ());
- stmt->u.R809.expr = expr;
- ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
- malloc_pool_use (ffestw_select (ffestw_stack_top ())->pool);
- }
-#endif
+ stmt = ffestd_stmt_new_ (FFESTD_stmtidR809_);
+ ffestd_stmt_append_ (stmt);
+ ffestd_subr_line_save_ (stmt);
+ stmt->u.R809.pool = ffesta_output_pool;
+ stmt->u.R809.block = ffestw_use (ffestw_stack_top ());
+ stmt->u.R809.expr = expr;
+ ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
+ malloc_pool_use (ffestw_select (ffestw_stack_top ())->pool);
++ffestd_block_level_;
assert (ffestd_block_level_ > 0);
void
ffestd_R810 (unsigned long casenum)
{
+ ffestdStmt_ stmt;
+
ffestd_check_simple_ ();
-#if FFECOM_ONEPASS
- ffestd_subr_line_now_ ();
- ffeste_R810 (ffestw_stack_top (), casenum);
-#else
- {
- ffestdStmt_ stmt;
-
- stmt = ffestd_stmt_new_ (FFESTD_stmtidR810_);
- ffestd_stmt_append_ (stmt);
- ffestd_subr_line_save_ (stmt);
- stmt->u.R810.pool = ffesta_output_pool;
- stmt->u.R810.block = ffestw_stack_top ();
- stmt->u.R810.casenum = casenum;
- ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
- }
-#endif
+ stmt = ffestd_stmt_new_ (FFESTD_stmtidR810_);
+ ffestd_stmt_append_ (stmt);
+ ffestd_subr_line_save_ (stmt);
+ stmt->u.R810.pool = ffesta_output_pool;
+ stmt->u.R810.block = ffestw_stack_top ();
+ stmt->u.R810.casenum = casenum;
+ ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
}
/* ffestd_R811 -- End a SELECT
void
ffestd_R811 (bool ok UNUSED)
{
-#if FFECOM_ONEPASS
- ffestd_subr_line_now_ ();
- ffeste_R811 (ffestw_stack_top ());
-#else
- {
- ffestdStmt_ stmt;
+ ffestdStmt_ stmt;
- stmt = ffestd_stmt_new_ (FFESTD_stmtidR811_);
- ffestd_stmt_append_ (stmt);
- ffestd_subr_line_save_ (stmt);
- stmt->u.R811.block = ffestw_stack_top ();
- }
-#endif
+ stmt = ffestd_stmt_new_ (FFESTD_stmtidR811_);
+ ffestd_stmt_append_ (stmt);
+ ffestd_subr_line_save_ (stmt);
+ stmt->u.R811.block = ffestw_stack_top ();
--ffestd_block_level_;
assert (ffestd_block_level_ >= 0);
ffebld end, ffelexToken end_token,
ffebld incr, ffelexToken incr_token)
{
+ ffestdStmt_ stmt;
+
ffestd_check_simple_ ();
-#if FFECOM_ONEPASS
- ffestd_subr_line_now_ ();
- ffeste_R819A (ffestw_stack_top (), label, var, start, end, incr,
- incr_token);
-#else
- {
- ffestdStmt_ stmt;
-
- stmt = ffestd_stmt_new_ (FFESTD_stmtidR819A_);
- ffestd_stmt_append_ (stmt);
- ffestd_subr_line_save_ (stmt);
- stmt->u.R819A.pool = ffesta_output_pool;
- stmt->u.R819A.block = ffestw_use (ffestw_stack_top ());
- stmt->u.R819A.label = label;
- stmt->u.R819A.var = var;
- stmt->u.R819A.start = start;
- stmt->u.R819A.start_token = ffelex_token_use (start_token);
- stmt->u.R819A.end = end;
- stmt->u.R819A.end_token = ffelex_token_use (end_token);
- stmt->u.R819A.incr = incr;
- stmt->u.R819A.incr_token = (incr_token == NULL) ? NULL
- : ffelex_token_use (incr_token);
- ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
- }
-#endif
+ stmt = ffestd_stmt_new_ (FFESTD_stmtidR819A_);
+ ffestd_stmt_append_ (stmt);
+ ffestd_subr_line_save_ (stmt);
+ stmt->u.R819A.pool = ffesta_output_pool;
+ stmt->u.R819A.block = ffestw_use (ffestw_stack_top ());
+ stmt->u.R819A.label = label;
+ stmt->u.R819A.var = var;
+ stmt->u.R819A.start = start;
+ stmt->u.R819A.start_token = ffelex_token_use (start_token);
+ stmt->u.R819A.end = end;
+ stmt->u.R819A.end_token = ffelex_token_use (end_token);
+ stmt->u.R819A.incr = incr;
+ stmt->u.R819A.incr_token = (incr_token == NULL) ? NULL
+ : ffelex_token_use (incr_token);
+ ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
++ffestd_block_level_;
assert (ffestd_block_level_ > 0);
ffestd_R819B (ffelexToken construct_name UNUSED, ffelab label,
ffebld expr)
{
+ ffestdStmt_ stmt;
+
ffestd_check_simple_ ();
-#if FFECOM_ONEPASS
- ffestd_subr_line_now_ ();
- ffeste_R819B (ffestw_stack_top (), label, expr);
-#else
- {
- ffestdStmt_ stmt;
-
- stmt = ffestd_stmt_new_ (FFESTD_stmtidR819B_);
- ffestd_stmt_append_ (stmt);
- ffestd_subr_line_save_ (stmt);
- stmt->u.R819B.pool = ffesta_output_pool;
- stmt->u.R819B.block = ffestw_use (ffestw_stack_top ());
- stmt->u.R819B.label = label;
- stmt->u.R819B.expr = expr;
- ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
- }
-#endif
+ stmt = ffestd_stmt_new_ (FFESTD_stmtidR819B_);
+ ffestd_stmt_append_ (stmt);
+ ffestd_subr_line_save_ (stmt);
+ stmt->u.R819B.pool = ffesta_output_pool;
+ stmt->u.R819B.block = ffestw_use (ffestw_stack_top ());
+ stmt->u.R819B.label = label;
+ stmt->u.R819B.expr = expr;
+ ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
++ffestd_block_level_;
assert (ffestd_block_level_ > 0);
void
ffestd_R825 (ffelexToken name UNUSED)
{
- ffestd_check_simple_ ();
+ ffestdStmt_ stmt;
-#if FFECOM_ONEPASS
- ffestd_subr_line_now_ ();
- ffeste_R825 ();
-#else
- {
- ffestdStmt_ stmt;
+ ffestd_check_simple_ ();
- stmt = ffestd_stmt_new_ (FFESTD_stmtidR825_);
- ffestd_stmt_append_ (stmt);
- ffestd_subr_line_save_ (stmt);
- }
-#endif
+ stmt = ffestd_stmt_new_ (FFESTD_stmtidR825_);
+ ffestd_stmt_append_ (stmt);
+ ffestd_subr_line_save_ (stmt);
}
/* ffestd_R834 -- CYCLE statement
void
ffestd_R834 (ffestw block)
{
- ffestd_check_simple_ ();
+ ffestdStmt_ stmt;
-#if FFECOM_ONEPASS
- ffestd_subr_line_now_ ();
- ffeste_R834 (block);
-#else
- {
- ffestdStmt_ stmt;
+ ffestd_check_simple_ ();
- stmt = ffestd_stmt_new_ (FFESTD_stmtidR834_);
- ffestd_stmt_append_ (stmt);
- ffestd_subr_line_save_ (stmt);
- stmt->u.R834.block = block;
- }
-#endif
+ stmt = ffestd_stmt_new_ (FFESTD_stmtidR834_);
+ ffestd_stmt_append_ (stmt);
+ ffestd_subr_line_save_ (stmt);
+ stmt->u.R834.block = block;
}
/* ffestd_R835 -- EXIT statement
void
ffestd_R835 (ffestw block)
{
- ffestd_check_simple_ ();
+ ffestdStmt_ stmt;
-#if FFECOM_ONEPASS
- ffestd_subr_line_now_ ();
- ffeste_R835 (block);
-#else
- {
- ffestdStmt_ stmt;
+ ffestd_check_simple_ ();
- stmt = ffestd_stmt_new_ (FFESTD_stmtidR835_);
- ffestd_stmt_append_ (stmt);
- ffestd_subr_line_save_ (stmt);
- stmt->u.R835.block = block;
- }
-#endif
+ stmt = ffestd_stmt_new_ (FFESTD_stmtidR835_);
+ ffestd_stmt_append_ (stmt);
+ ffestd_subr_line_save_ (stmt);
+ stmt->u.R835.block = block;
}
/* ffestd_R836 -- GOTO statement
void
ffestd_R836 (ffelab label)
{
- ffestd_check_simple_ ();
+ ffestdStmt_ stmt;
-#if FFECOM_ONEPASS
- ffestd_subr_line_now_ ();
- ffeste_R836 (label);
-#else
- {
- ffestdStmt_ stmt;
+ ffestd_check_simple_ ();
- stmt = ffestd_stmt_new_ (FFESTD_stmtidR836_);
- ffestd_stmt_append_ (stmt);
- ffestd_subr_line_save_ (stmt);
- stmt->u.R836.label = label;
- }
-#endif
+ stmt = ffestd_stmt_new_ (FFESTD_stmtidR836_);
+ ffestd_stmt_append_ (stmt);
+ ffestd_subr_line_save_ (stmt);
+ stmt->u.R836.label = label;
if (ffestd_block_level_ == 0)
ffestd_is_reachable_ = FALSE;
void
ffestd_R837 (ffelab *labels, int count, ffebld expr)
{
+ ffestdStmt_ stmt;
+
ffestd_check_simple_ ();
-#if FFECOM_ONEPASS
- ffestd_subr_line_now_ ();
- ffeste_R837 (labels, count, expr);
-#else
- {
- ffestdStmt_ stmt;
-
- stmt = ffestd_stmt_new_ (FFESTD_stmtidR837_);
- ffestd_stmt_append_ (stmt);
- ffestd_subr_line_save_ (stmt);
- stmt->u.R837.pool = ffesta_output_pool;
- stmt->u.R837.labels = labels;
- stmt->u.R837.count = count;
- stmt->u.R837.expr = expr;
- ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
- }
-#endif
+ stmt = ffestd_stmt_new_ (FFESTD_stmtidR837_);
+ ffestd_stmt_append_ (stmt);
+ ffestd_subr_line_save_ (stmt);
+ stmt->u.R837.pool = ffesta_output_pool;
+ stmt->u.R837.labels = labels;
+ stmt->u.R837.count = count;
+ stmt->u.R837.expr = expr;
+ ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
}
/* ffestd_R838 -- ASSIGN statement
void
ffestd_R838 (ffelab label, ffebld target)
{
+ ffestdStmt_ stmt;
+
ffestd_check_simple_ ();
-#if FFECOM_ONEPASS
- ffestd_subr_line_now_ ();
- ffeste_R838 (label, target);
-#else
- {
- ffestdStmt_ stmt;
-
- stmt = ffestd_stmt_new_ (FFESTD_stmtidR838_);
- ffestd_stmt_append_ (stmt);
- ffestd_subr_line_save_ (stmt);
- stmt->u.R838.pool = ffesta_output_pool;
- stmt->u.R838.label = label;
- stmt->u.R838.target = target;
- ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
- }
-#endif
+ stmt = ffestd_stmt_new_ (FFESTD_stmtidR838_);
+ ffestd_stmt_append_ (stmt);
+ ffestd_subr_line_save_ (stmt);
+ stmt->u.R838.pool = ffesta_output_pool;
+ stmt->u.R838.label = label;
+ stmt->u.R838.target = target;
+ ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
}
/* ffestd_R839 -- Assigned GOTO statement
void
ffestd_R839 (ffebld target, ffelab *labels UNUSED, int count UNUSED)
{
+ ffestdStmt_ stmt;
+
ffestd_check_simple_ ();
-#if FFECOM_ONEPASS
- ffestd_subr_line_now_ ();
- ffeste_R839 (target);
-#else
- {
- ffestdStmt_ stmt;
-
- stmt = ffestd_stmt_new_ (FFESTD_stmtidR839_);
- ffestd_stmt_append_ (stmt);
- ffestd_subr_line_save_ (stmt);
- stmt->u.R839.pool = ffesta_output_pool;
- stmt->u.R839.target = target;
- ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
- }
-#endif
+ stmt = ffestd_stmt_new_ (FFESTD_stmtidR839_);
+ ffestd_stmt_append_ (stmt);
+ ffestd_subr_line_save_ (stmt);
+ stmt->u.R839.pool = ffesta_output_pool;
+ stmt->u.R839.target = target;
+ ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
if (ffestd_block_level_ == 0)
ffestd_is_reachable_ = FALSE;
void
ffestd_R840 (ffebld expr, ffelab neg, ffelab zero, ffelab pos)
{
+ ffestdStmt_ stmt;
+
ffestd_check_simple_ ();
-#if FFECOM_ONEPASS
- ffestd_subr_line_now_ ();
- ffeste_R840 (expr, neg, zero, pos);
-#else
- {
- ffestdStmt_ stmt;
-
- stmt = ffestd_stmt_new_ (FFESTD_stmtidR840_);
- ffestd_stmt_append_ (stmt);
- ffestd_subr_line_save_ (stmt);
- stmt->u.R840.pool = ffesta_output_pool;
- stmt->u.R840.expr = expr;
- stmt->u.R840.neg = neg;
- stmt->u.R840.zero = zero;
- stmt->u.R840.pos = pos;
- ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
- }
-#endif
+ stmt = ffestd_stmt_new_ (FFESTD_stmtidR840_);
+ ffestd_stmt_append_ (stmt);
+ ffestd_subr_line_save_ (stmt);
+ stmt->u.R840.pool = ffesta_output_pool;
+ stmt->u.R840.expr = expr;
+ stmt->u.R840.neg = neg;
+ stmt->u.R840.zero = zero;
+ stmt->u.R840.pos = pos;
+ ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
if (ffestd_block_level_ == 0)
ffestd_is_reachable_ = FALSE;
void
ffestd_R841 (bool in_where UNUSED)
{
- ffestd_check_simple_ ();
+ ffestdStmt_ stmt;
-#if FFECOM_ONEPASS
- ffestd_subr_line_now_ ();
- ffeste_R841 ();
-#else
- {
- ffestdStmt_ stmt;
+ ffestd_check_simple_ ();
- stmt = ffestd_stmt_new_ (FFESTD_stmtidR841_);
- ffestd_stmt_append_ (stmt);
- ffestd_subr_line_save_ (stmt);
- }
-#endif
+ stmt = ffestd_stmt_new_ (FFESTD_stmtidR841_);
+ ffestd_stmt_append_ (stmt);
+ ffestd_subr_line_save_ (stmt);
}
/* ffestd_R842 -- STOP statement
void
ffestd_R842 (ffebld expr)
{
- ffestd_check_simple_ ();
+ ffestdStmt_ stmt;
-#if FFECOM_ONEPASS
- ffestd_subr_line_now_ ();
- ffeste_R842 (expr);
-#else
- {
- ffestdStmt_ stmt;
+ ffestd_check_simple_ ();
- stmt = ffestd_stmt_new_ (FFESTD_stmtidR842_);
- ffestd_stmt_append_ (stmt);
- ffestd_subr_line_save_ (stmt);
- if (ffesta_outpooldisp () == FFESTA_pooldispPRESERVE)
- {
- /* This is a "spurious" (automatically-generated) STOP
- that follows a previous STOP or other statement.
- Make sure we don't have an expression in the pool,
- and then mark that the pool has already been killed. */
- assert (expr == NULL);
- stmt->u.R842.pool = NULL;
- stmt->u.R842.expr = NULL;
- }
- else
- {
- stmt->u.R842.pool = ffesta_output_pool;
- stmt->u.R842.expr = expr;
- ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
- }
- }
-#endif
+ stmt = ffestd_stmt_new_ (FFESTD_stmtidR842_);
+ ffestd_stmt_append_ (stmt);
+ ffestd_subr_line_save_ (stmt);
+ if (ffesta_outpooldisp () == FFESTA_pooldispPRESERVE)
+ {
+ /* This is a "spurious" (automatically-generated) STOP
+ that follows a previous STOP or other statement.
+ Make sure we don't have an expression in the pool,
+ and then mark that the pool has already been killed. */
+ assert (expr == NULL);
+ stmt->u.R842.pool = NULL;
+ stmt->u.R842.expr = NULL;
+ }
+ else
+ {
+ stmt->u.R842.pool = ffesta_output_pool;
+ stmt->u.R842.expr = expr;
+ ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
+ }
if (ffestd_block_level_ == 0)
ffestd_is_reachable_ = FALSE;
void
ffestd_R843 (ffebld expr)
{
+ ffestdStmt_ stmt;
+
ffestd_check_simple_ ();
-#if FFECOM_ONEPASS
- ffestd_subr_line_now_ ();
- ffeste_R843 (expr);
-#else
- {
- ffestdStmt_ stmt;
-
- stmt = ffestd_stmt_new_ (FFESTD_stmtidR843_);
- ffestd_stmt_append_ (stmt);
- ffestd_subr_line_save_ (stmt);
- stmt->u.R843.pool = ffesta_output_pool;
- stmt->u.R843.expr = expr;
- ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
- }
-#endif
+ stmt = ffestd_stmt_new_ (FFESTD_stmtidR843_);
+ ffestd_stmt_append_ (stmt);
+ ffestd_subr_line_save_ (stmt);
+ stmt->u.R843.pool = ffesta_output_pool;
+ stmt->u.R843.expr = expr;
+ ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
}
/* ffestd_R904 -- OPEN statement
void
ffestd_R904 ()
{
+ ffestdStmt_ stmt;
+
ffestd_check_simple_ ();
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
#define specified(something) \
(ffestp_file.open.open_spec[something].kw_or_val_present)
}
#undef specified
-#endif
-#if FFECOM_ONEPASS
- ffestd_subr_line_now_ ();
- ffeste_R904 (&ffestp_file.open);
-#else
- {
- ffestdStmt_ stmt;
-
- stmt = ffestd_stmt_new_ (FFESTD_stmtidR904_);
- ffestd_stmt_append_ (stmt);
- ffestd_subr_line_save_ (stmt);
- stmt->u.R904.pool = ffesta_output_pool;
- stmt->u.R904.params = ffestd_subr_copy_open_ ();
- ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
- }
-#endif
+ stmt = ffestd_stmt_new_ (FFESTD_stmtidR904_);
+ ffestd_stmt_append_ (stmt);
+ ffestd_subr_line_save_ (stmt);
+ stmt->u.R904.pool = ffesta_output_pool;
+ stmt->u.R904.params = ffestd_subr_copy_open_ ();
+ ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
}
/* ffestd_R907 -- CLOSE statement
void
ffestd_R907 ()
{
+ ffestdStmt_ stmt;
+
ffestd_check_simple_ ();
-#if FFECOM_ONEPASS
- ffestd_subr_line_now_ ();
- ffeste_R907 (&ffestp_file.close);
-#else
- {
- ffestdStmt_ stmt;
-
- stmt = ffestd_stmt_new_ (FFESTD_stmtidR907_);
- ffestd_stmt_append_ (stmt);
- ffestd_subr_line_save_ (stmt);
- stmt->u.R907.pool = ffesta_output_pool;
- stmt->u.R907.params = ffestd_subr_copy_close_ ();
- ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
- }
-#endif
+ stmt = ffestd_stmt_new_ (FFESTD_stmtidR907_);
+ ffestd_stmt_append_ (stmt);
+ ffestd_subr_line_save_ (stmt);
+ stmt->u.R907.pool = ffesta_output_pool;
+ stmt->u.R907.params = ffestd_subr_copy_close_ ();
+ ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
}
/* ffestd_R909_start -- READ(...) statement list begin
ffestd_R909_start (bool only_format, ffestvUnit unit,
ffestvFormat format, bool rec, bool key)
{
+ ffestdStmt_ stmt;
+
ffestd_check_start_ ();
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
#define specified(something) \
(ffestp_file.read.read_spec[something].kw_or_val_present)
}
#undef specified
-#endif
-#if FFECOM_ONEPASS
- ffestd_subr_line_now_ ();
- ffeste_R909_start (&ffestp_file.read, only_format, unit, format, rec, key);
-#else
- {
- ffestdStmt_ stmt;
-
- stmt = ffestd_stmt_new_ (FFESTD_stmtidR909_);
- ffestd_stmt_append_ (stmt);
- ffestd_subr_line_save_ (stmt);
- stmt->u.R909.pool = ffesta_output_pool;
- stmt->u.R909.params = ffestd_subr_copy_read_ ();
- stmt->u.R909.only_format = only_format;
- stmt->u.R909.unit = unit;
- stmt->u.R909.format = format;
- stmt->u.R909.rec = rec;
- stmt->u.R909.key = key;
- stmt->u.R909.list = NULL;
- ffestd_expr_list_ = &stmt->u.R909.list;
- ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
- }
-#endif
+ stmt = ffestd_stmt_new_ (FFESTD_stmtidR909_);
+ ffestd_stmt_append_ (stmt);
+ ffestd_subr_line_save_ (stmt);
+ stmt->u.R909.pool = ffesta_output_pool;
+ stmt->u.R909.params = ffestd_subr_copy_read_ ();
+ stmt->u.R909.only_format = only_format;
+ stmt->u.R909.unit = unit;
+ stmt->u.R909.format = format;
+ stmt->u.R909.rec = rec;
+ stmt->u.R909.key = key;
+ stmt->u.R909.list = NULL;
+ ffestd_expr_list_ = &stmt->u.R909.list;
+ ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
}
/* ffestd_R909_item -- READ statement i/o item
void
ffestd_R909_item (ffebld expr, ffelexToken expr_token)
{
+ ffestdExprItem_ item;
+
ffestd_check_item_ ();
-#if FFECOM_ONEPASS
- ffeste_R909_item (expr);
-#else
- {
- ffestdExprItem_ item
- = (ffestdExprItem_) malloc_new_kp (ffesta_output_pool, "ffestdExprItem_",
- sizeof (*item));
-
- item->next = NULL;
- item->expr = expr;
- item->token = ffelex_token_use (expr_token);
- *ffestd_expr_list_ = item;
- ffestd_expr_list_ = &item->next;
- }
-#endif
+ item = (ffestdExprItem_) malloc_new_kp (ffesta_output_pool,
+ "ffestdExprItem_", sizeof (*item));
+
+ item->next = NULL;
+ item->expr = expr;
+ item->token = ffelex_token_use (expr_token);
+ *ffestd_expr_list_ = item;
+ ffestd_expr_list_ = &item->next;
}
/* ffestd_R909_finish -- READ statement list complete
ffestd_R909_finish ()
{
ffestd_check_finish_ ();
-
-#if FFECOM_ONEPASS
- ffeste_R909_finish ();
-#else
- /* Nothing to do, it's implicit. */
-#endif
}
/* ffestd_R910_start -- WRITE(...) statement list begin
void
ffestd_R910_start (ffestvUnit unit, ffestvFormat format, bool rec)
{
+ ffestdStmt_ stmt;
+
ffestd_check_start_ ();
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
#define specified(something) \
(ffestp_file.write.write_spec[something].kw_or_val_present)
}
#undef specified
-#endif
-#if FFECOM_ONEPASS
- ffestd_subr_line_now_ ();
- ffeste_R910_start (&ffestp_file.write, unit, format, rec);
-#else
- {
- ffestdStmt_ stmt;
-
- stmt = ffestd_stmt_new_ (FFESTD_stmtidR910_);
- ffestd_stmt_append_ (stmt);
- ffestd_subr_line_save_ (stmt);
- stmt->u.R910.pool = ffesta_output_pool;
- stmt->u.R910.params = ffestd_subr_copy_write_ ();
- stmt->u.R910.unit = unit;
- stmt->u.R910.format = format;
- stmt->u.R910.rec = rec;
- stmt->u.R910.list = NULL;
- ffestd_expr_list_ = &stmt->u.R910.list;
- ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
- }
-#endif
+ stmt = ffestd_stmt_new_ (FFESTD_stmtidR910_);
+ ffestd_stmt_append_ (stmt);
+ ffestd_subr_line_save_ (stmt);
+ stmt->u.R910.pool = ffesta_output_pool;
+ stmt->u.R910.params = ffestd_subr_copy_write_ ();
+ stmt->u.R910.unit = unit;
+ stmt->u.R910.format = format;
+ stmt->u.R910.rec = rec;
+ stmt->u.R910.list = NULL;
+ ffestd_expr_list_ = &stmt->u.R910.list;
+ ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
}
/* ffestd_R910_item -- WRITE statement i/o item
void
ffestd_R910_item (ffebld expr, ffelexToken expr_token)
{
+ ffestdExprItem_ item;
+
ffestd_check_item_ ();
-#if FFECOM_ONEPASS
- ffeste_R910_item (expr);
-#else
- {
- ffestdExprItem_ item
- = (ffestdExprItem_) malloc_new_kp (ffesta_output_pool, "ffestdExprItem_",
- sizeof (*item));
-
- item->next = NULL;
- item->expr = expr;
- item->token = ffelex_token_use (expr_token);
- *ffestd_expr_list_ = item;
- ffestd_expr_list_ = &item->next;
- }
-#endif
+ item = (ffestdExprItem_) malloc_new_kp (ffesta_output_pool,
+ "ffestdExprItem_", sizeof (*item));
+
+ item->next = NULL;
+ item->expr = expr;
+ item->token = ffelex_token_use (expr_token);
+ *ffestd_expr_list_ = item;
+ ffestd_expr_list_ = &item->next;
}
/* ffestd_R910_finish -- WRITE statement list complete
ffestd_R910_finish ()
{
ffestd_check_finish_ ();
-
-#if FFECOM_ONEPASS
- ffeste_R910_finish ();
-#else
- /* Nothing to do, it's implicit. */
-#endif
}
/* ffestd_R911_start -- PRINT statement list begin
void
ffestd_R911_start (ffestvFormat format)
{
+ ffestdStmt_ stmt;
+
ffestd_check_start_ ();
-#if FFECOM_ONEPASS
- ffestd_subr_line_now_ ();
- ffeste_R911_start (&ffestp_file.print, format);
-#else
- {
- ffestdStmt_ stmt;
-
- stmt = ffestd_stmt_new_ (FFESTD_stmtidR911_);
- ffestd_stmt_append_ (stmt);
- ffestd_subr_line_save_ (stmt);
- stmt->u.R911.pool = ffesta_output_pool;
- stmt->u.R911.params = ffestd_subr_copy_print_ ();
- stmt->u.R911.format = format;
- stmt->u.R911.list = NULL;
- ffestd_expr_list_ = &stmt->u.R911.list;
- ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
- }
-#endif
+ stmt = ffestd_stmt_new_ (FFESTD_stmtidR911_);
+ ffestd_stmt_append_ (stmt);
+ ffestd_subr_line_save_ (stmt);
+ stmt->u.R911.pool = ffesta_output_pool;
+ stmt->u.R911.params = ffestd_subr_copy_print_ ();
+ stmt->u.R911.format = format;
+ stmt->u.R911.list = NULL;
+ ffestd_expr_list_ = &stmt->u.R911.list;
+ ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
}
/* ffestd_R911_item -- PRINT statement i/o item
void
ffestd_R911_item (ffebld expr, ffelexToken expr_token)
{
+ ffestdExprItem_ item;
+
ffestd_check_item_ ();
-#if FFECOM_ONEPASS
- ffeste_R911_item (expr);
-#else
- {
- ffestdExprItem_ item
- = (ffestdExprItem_) malloc_new_kp (ffesta_output_pool, "ffestdExprItem_",
- sizeof (*item));
-
- item->next = NULL;
- item->expr = expr;
- item->token = ffelex_token_use (expr_token);
- *ffestd_expr_list_ = item;
- ffestd_expr_list_ = &item->next;
- }
-#endif
+ item = (ffestdExprItem_) malloc_new_kp (ffesta_output_pool,
+ "ffestdExprItem_", sizeof (*item));
+
+ item->next = NULL;
+ item->expr = expr;
+ item->token = ffelex_token_use (expr_token);
+ *ffestd_expr_list_ = item;
+ ffestd_expr_list_ = &item->next;
}
/* ffestd_R911_finish -- PRINT statement list complete
ffestd_R911_finish ()
{
ffestd_check_finish_ ();
-
-#if FFECOM_ONEPASS
- ffeste_R911_finish ();
-#else
- /* Nothing to do, it's implicit. */
-#endif
}
/* ffestd_R919 -- BACKSPACE statement
void
ffestd_R919 ()
{
+ ffestdStmt_ stmt;
+
ffestd_check_simple_ ();
-#if FFECOM_ONEPASS
- ffestd_subr_line_now_ ();
- ffeste_R919 (&ffestp_file.beru);
-#else
- {
- ffestdStmt_ stmt;
-
- stmt = ffestd_stmt_new_ (FFESTD_stmtidR919_);
- ffestd_stmt_append_ (stmt);
- ffestd_subr_line_save_ (stmt);
- stmt->u.R919.pool = ffesta_output_pool;
- stmt->u.R919.params = ffestd_subr_copy_beru_ ();
- ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
- }
-#endif
+ stmt = ffestd_stmt_new_ (FFESTD_stmtidR919_);
+ ffestd_stmt_append_ (stmt);
+ ffestd_subr_line_save_ (stmt);
+ stmt->u.R919.pool = ffesta_output_pool;
+ stmt->u.R919.params = ffestd_subr_copy_beru_ ();
+ ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
}
/* ffestd_R920 -- ENDFILE statement
void
ffestd_R920 ()
{
+ ffestdStmt_ stmt;
+
ffestd_check_simple_ ();
-#if FFECOM_ONEPASS
- ffestd_subr_line_now_ ();
- ffeste_R920 (&ffestp_file.beru);
-#else
- {
- ffestdStmt_ stmt;
-
- stmt = ffestd_stmt_new_ (FFESTD_stmtidR920_);
- ffestd_stmt_append_ (stmt);
- ffestd_subr_line_save_ (stmt);
- stmt->u.R920.pool = ffesta_output_pool;
- stmt->u.R920.params = ffestd_subr_copy_beru_ ();
- ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
- }
-#endif
+ stmt = ffestd_stmt_new_ (FFESTD_stmtidR920_);
+ ffestd_stmt_append_ (stmt);
+ ffestd_subr_line_save_ (stmt);
+ stmt->u.R920.pool = ffesta_output_pool;
+ stmt->u.R920.params = ffestd_subr_copy_beru_ ();
+ ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
}
/* ffestd_R921 -- REWIND statement
void
ffestd_R921 ()
{
+ ffestdStmt_ stmt;
+
ffestd_check_simple_ ();
-#if FFECOM_ONEPASS
- ffestd_subr_line_now_ ();
- ffeste_R921 (&ffestp_file.beru);
-#else
- {
- ffestdStmt_ stmt;
-
- stmt = ffestd_stmt_new_ (FFESTD_stmtidR921_);
- ffestd_stmt_append_ (stmt);
- ffestd_subr_line_save_ (stmt);
- stmt->u.R921.pool = ffesta_output_pool;
- stmt->u.R921.params = ffestd_subr_copy_beru_ ();
- ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
- }
-#endif
+ stmt = ffestd_stmt_new_ (FFESTD_stmtidR921_);
+ ffestd_stmt_append_ (stmt);
+ ffestd_subr_line_save_ (stmt);
+ stmt->u.R921.pool = ffesta_output_pool;
+ stmt->u.R921.params = ffestd_subr_copy_beru_ ();
+ ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
}
/* ffestd_R923A -- INQUIRE statement (non-IOLENGTH version)
void
ffestd_R923A (bool by_file)
{
+ ffestdStmt_ stmt;
+
ffestd_check_simple_ ();
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
#define specified(something) \
(ffestp_file.inquire.inquire_spec[something].kw_or_val_present)
}
#undef specified
-#endif
-#if FFECOM_ONEPASS
- ffestd_subr_line_now_ ();
- ffeste_R923A (&ffestp_file.inquire, by_file);
-#else
- {
- ffestdStmt_ stmt;
-
- stmt = ffestd_stmt_new_ (FFESTD_stmtidR923A_);
- ffestd_stmt_append_ (stmt);
- ffestd_subr_line_save_ (stmt);
- stmt->u.R923A.pool = ffesta_output_pool;
- stmt->u.R923A.params = ffestd_subr_copy_inquire_ ();
- stmt->u.R923A.by_file = by_file;
- ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
- }
-#endif
+ stmt = ffestd_stmt_new_ (FFESTD_stmtidR923A_);
+ ffestd_stmt_append_ (stmt);
+ ffestd_subr_line_save_ (stmt);
+ stmt->u.R923A.pool = ffesta_output_pool;
+ stmt->u.R923A.params = ffestd_subr_copy_inquire_ ();
+ stmt->u.R923A.by_file = by_file;
+ ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
}
/* ffestd_R923B_start -- INQUIRE(IOLENGTH=expr) statement list begin
void
ffestd_R923B_start ()
{
+ ffestdStmt_ stmt;
+
ffestd_check_start_ ();
-#if FFECOM_ONEPASS
- ffestd_subr_line_now_ ();
- ffeste_R923B_start (&ffestp_file.inquire);
-#else
- {
- ffestdStmt_ stmt;
-
- stmt = ffestd_stmt_new_ (FFESTD_stmtidR923B_);
- ffestd_stmt_append_ (stmt);
- ffestd_subr_line_save_ (stmt);
- stmt->u.R923B.pool = ffesta_output_pool;
- stmt->u.R923B.params = ffestd_subr_copy_inquire_ ();
- stmt->u.R923B.list = NULL;
- ffestd_expr_list_ = &stmt->u.R923B.list;
- ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
- }
-#endif
+ stmt = ffestd_stmt_new_ (FFESTD_stmtidR923B_);
+ ffestd_stmt_append_ (stmt);
+ ffestd_subr_line_save_ (stmt);
+ stmt->u.R923B.pool = ffesta_output_pool;
+ stmt->u.R923B.params = ffestd_subr_copy_inquire_ ();
+ stmt->u.R923B.list = NULL;
+ ffestd_expr_list_ = &stmt->u.R923B.list;
+ ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
}
/* ffestd_R923B_item -- INQUIRE statement i/o item
void
ffestd_R923B_item (ffebld expr)
{
+ ffestdExprItem_ item;
+
ffestd_check_item_ ();
-#if FFECOM_ONEPASS
- ffeste_R923B_item (expr);
-#else
- {
- ffestdExprItem_ item
- = (ffestdExprItem_) malloc_new_kp (ffesta_output_pool, "ffestdExprItem_",
- sizeof (*item));
-
- item->next = NULL;
- item->expr = expr;
- *ffestd_expr_list_ = item;
- ffestd_expr_list_ = &item->next;
- }
-#endif
+ item = (ffestdExprItem_) malloc_new_kp (ffesta_output_pool,
+ "ffestdExprItem_", sizeof (*item));
+
+ item->next = NULL;
+ item->expr = expr;
+ *ffestd_expr_list_ = item;
+ ffestd_expr_list_ = &item->next;
}
/* ffestd_R923B_finish -- INQUIRE statement list complete
ffestd_R923B_finish ()
{
ffestd_check_finish_ ();
-
-#if FFECOM_ONEPASS
- ffeste_R923B_finish ();
-#else
- /* Nothing to do, it's implicit. */
-#endif
}
/* ffestd_R1001 -- FORMAT statement
{
ffestsHolder str;
ffests s = &str;
+ ffestdStmt_ stmt;
ffestd_check_simple_ ();
ffestd_R1001dump_ (s, f); /* Build the string in s. */
ffests_putc (s, ')');
-#if FFECOM_ONEPASS
- ffeste_R1001 (s);
- ffests_kill (s); /* Kill the string in s. */
-#else
- {
- ffestdStmt_ stmt;
-
- stmt = ffestd_stmt_new_ (FFESTD_stmtidR1001_);
-#if 0
- /* Don't bother with this. After all, things like cilists also are
- declared midway through code-generation. Perhaps the only problems
- the gcc back end has with midway declarations are with stack vars,
- maybe only with vars that can be put in registers. Unless/until the
- need is established, handle FORMAT just like cilists and others; at
- that point, they'd likely *all* have to be fixed, which would be
- very painful anyway. */
- /* Insert FORMAT statement just after the first item on the
- statement list, which must be a FORMAT label, which see. */
- assert (ffestd_stmt_list_.first->id == FFESTD_stmtidFORMATLABEL_);
- stmt->previous = ffestd_stmt_list_.first;
- stmt->next = ffestd_stmt_list_.first->next;
- stmt->next->previous = stmt;
- stmt->previous->next = stmt;
-#else
- ffestd_stmt_append_ (stmt);
-#endif
- stmt->u.R1001.str = str;
- }
-#endif
+ stmt = ffestd_stmt_new_ (FFESTD_stmtidR1001_);
+ ffestd_stmt_append_ (stmt);
+ stmt->u.R1001.str = str;
ffestd_label_formatdef_ = NULL;
}
break;
case FFESTP_formattypeB:
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- ffestd_R1001dump_1005_3_ (s, next, "B");
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
ffestd_R1001error_ (next);
-#else
-#error
-#endif
break;
case FFESTP_formattypeO:
break;
case FFESTP_formattypeEN:
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- ffestd_R1001dump_1005_5_ (s, next, "EN");
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
ffestd_R1001error_ (next);
-#else
-#error
-#endif
break;
case FFESTP_formattypeG:
break;
case FFESTP_formattypeQ:
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- ffestd_R1001dump_1010_1_ (s, next, "Q");
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
ffestd_R1001error_ (next);
-#else
-#error
-#endif
break;
case FFESTP_formattypeDOLLAR:
ffe_set_is_saveall (TRUE); /* Main program always has implicit SAVE. */
ffestw_set_sym (ffestw_stack_top (), s);
-
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- if (name == NULL)
- fputs ("< PROGRAM_unnamed\n", dmpout);
- else
- fprintf (dmpout, "< PROGRAM %s\n", ffelex_token_text (name));
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
-#else
-#error
-#endif
}
/* ffestd_R1103 -- End a PROGRAM
void
ffestd_R1103 (bool ok UNUSED)
{
+ ffestdStmt_ stmt;
+
assert (ffestd_block_level_ == 0);
if (FFESTD_IS_END_OPTIMIZED_ && ffestd_is_reachable_)
if (ffestw_state (ffestw_stack_top ()) != FFESTV_statePROGRAM5)
ffestd_subr_labels_ (FALSE);/* Handle any undefined labels. */
-#if FFECOM_ONEPASS
- ffeste_R1103 ();
-#else
- {
- ffestdStmt_ stmt;
-
- stmt = ffestd_stmt_new_ (FFESTD_stmtidR1103_);
- ffestd_stmt_append_ (stmt);
- }
-#endif
+ stmt = ffestd_stmt_new_ (FFESTD_stmtidR1103_);
+ ffestd_stmt_append_ (stmt);
}
/* ffestd_R1105 -- MODULE statement
ffecom_notify_primary_entry (s);
ffestw_set_sym (ffestw_stack_top (), s);
-
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- if (name == NULL)
- fputs ("< BLOCK_DATA_unnamed\n", dmpout);
- else
- fprintf (dmpout, "< BLOCK_DATA %s\n", ffelex_token_text (name));
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
-#else
-#error
-#endif
}
/* ffestd_R1112 -- End a BLOCK DATA
void
ffestd_R1112 (bool ok UNUSED)
{
+ ffestdStmt_ stmt;
+
assert (ffestd_block_level_ == 0);
/* Generate any return-like code here (not likely for BLOCK DATA!). */
if (ffestw_state (ffestw_stack_top ()) != FFESTV_stateBLOCKDATA5)
ffestd_subr_labels_ (TRUE); /* Handle any undefined labels. */
-#if FFECOM_ONEPASS
- ffeste_R1112 ();
-#else
- {
- ffestdStmt_ stmt;
-
- stmt = ffestd_stmt_new_ (FFESTD_stmtidR1112_);
- ffestd_stmt_append_ (stmt);
- }
-#endif
+ stmt = ffestd_stmt_new_ (FFESTD_stmtidR1112_);
+ ffestd_stmt_append_ (stmt);
}
/* ffestd_R1202 -- INTERFACE statement
ffestd_R1207_start ()
{
ffestd_check_start_ ();
-
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- fputs ("* EXTERNAL (", dmpout);
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
-#else
-#error
-#endif
}
/* ffestd_R1207_item -- EXTERNAL statement for name
{
ffestd_check_item_ ();
assert (name != NULL);
-
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- fprintf (dmpout, "%s,", ffelex_token_text (name));
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
-#else
-#error
-#endif
}
/* ffestd_R1207_finish -- EXTERNAL statement list complete
ffestd_R1207_finish ()
{
ffestd_check_finish_ ();
-
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- fputs (")\n", dmpout);
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
-#else
-#error
-#endif
}
/* ffestd_R1208_start -- INTRINSIC statement list begin
ffestd_R1208_start ()
{
ffestd_check_start_ ();
-
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- fputs ("* INTRINSIC (", dmpout);
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
-#else
-#error
-#endif
}
/* ffestd_R1208_item -- INTRINSIC statement for name
{
ffestd_check_item_ ();
assert (name != NULL);
-
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- fprintf (dmpout, "%s,", ffelex_token_text (name));
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
-#else
-#error
-#endif
}
/* ffestd_R1208_finish -- INTRINSIC statement list complete
ffestd_R1208_finish ()
{
ffestd_check_finish_ ();
-
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- fputs (")\n", dmpout);
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
-#else
-#error
-#endif
}
/* ffestd_R1212 -- CALL statement
void
ffestd_R1212 (ffebld expr)
{
+ ffestdStmt_ stmt;
+
ffestd_check_simple_ ();
-#if FFECOM_ONEPASS
- ffestd_subr_line_now_ ();
- ffeste_R1212 (expr);
-#else
- {
- ffestdStmt_ stmt;
-
- stmt = ffestd_stmt_new_ (FFESTD_stmtidR1212_);
- ffestd_stmt_append_ (stmt);
- ffestd_subr_line_save_ (stmt);
- stmt->u.R1212.pool = ffesta_output_pool;
- stmt->u.R1212.expr = expr;
- ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
- }
-#endif
+ stmt = ffestd_stmt_new_ (FFESTD_stmtidR1212_);
+ ffestd_stmt_append_ (stmt);
+ ffestd_subr_line_save_ (stmt);
+ stmt->u.R1212.pool = ffesta_output_pool;
+ stmt->u.R1212.expr = expr;
+ ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
}
/* ffestd_R1213 -- Defined assignment statement
ffestd_check_simple_ ();
ffestd_subr_f90_ ();
- return;
-
-#ifdef FFESTD_F90
- fputs ("+ let_defined ", dmpout);
- ffebld_dump (dest);
- fputs ("=", dmpout);
- ffebld_dump (source);
- fputc ('\n', dmpout);
-#endif
}
#endif
bool recursive UNUSED, ffelexToken result UNUSED,
bool separate_result UNUSED)
{
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- char *a;
-#endif
-
assert (ffestd_block_level_ == 0);
ffestd_is_reachable_ = TRUE;
ffecom_notify_primary_entry (s);
ffestw_set_sym (ffestw_stack_top (), s);
+}
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- switch (type)
- {
- case FFESTP_typeINTEGER:
- a = "INTEGER";
- break;
+/* ffestd_R1221 -- End a FUNCTION
- case FFESTP_typeBYTE:
- a = "BYTE";
- break;
+ ffestd_R1221(TRUE); */
- case FFESTP_typeWORD:
- a = "WORD";
- break;
+void
+ffestd_R1221 (bool ok UNUSED)
+{
+ ffestdStmt_ stmt;
- case FFESTP_typeREAL:
- a = "REAL";
- break;
+ assert (ffestd_block_level_ == 0);
- case FFESTP_typeCOMPLEX:
- a = "COMPLEX";
- break;
+ if (FFESTD_IS_END_OPTIMIZED_ && ffestd_is_reachable_)
+ ffestd_R1227 (NULL); /* Generate RETURN. */
- case FFESTP_typeLOGICAL:
- a = "LOGICAL";
- break;
+ if (ffestw_state (ffestw_stack_top ()) != FFESTV_stateFUNCTION5)
+ ffestd_subr_labels_ (FALSE);/* Handle any undefined labels. */
- case FFESTP_typeCHARACTER:
- a = "CHARACTER";
- break;
-
- case FFESTP_typeDBLPRCSN:
- a = "DOUBLE PRECISION";
- break;
-
- case FFESTP_typeDBLCMPLX:
- a = "DOUBLE COMPLEX";
- break;
-
-#if FFESTR_F90
- case FFESTP_typeTYPE:
- a = "TYPE";
- break;
-#endif
-
- case FFESTP_typeNone:
- a = "";
- break;
-
- default:
- assert (FALSE);
- a = "?";
- break;
- }
- fprintf (dmpout, "< FUNCTION %s ", ffelex_token_text (funcname));
- if (recursive)
- fputs ("RECURSIVE ", dmpout);
- fprintf (dmpout, "%s(", a);
- if (kindt != NULL)
- {
- fputs ("kind=", dmpout);
- if (kind == NULL)
- fputs (ffelex_token_text (kindt), dmpout);
- else
- ffebld_dump (kind);
- if (lent != NULL)
- fputc (',', dmpout);
- }
- if (lent != NULL)
- {
- fputs ("len=", dmpout);
- if (len == NULL)
- fputs (ffelex_token_text (lent), dmpout);
- else
- ffebld_dump (len);
- }
- fprintf (dmpout, ")");
- if (args != NULL)
- {
- fputs (" (", dmpout);
- ffestt_tokenlist_dump (args);
- fputc (')', dmpout);
- }
- if (result != NULL)
- fprintf (dmpout, " result(%s)", ffelex_token_text (result));
- fputc ('\n', dmpout);
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
-#else
-#error
-#endif
-}
-
-/* ffestd_R1221 -- End a FUNCTION
-
- ffestd_R1221(TRUE); */
-
-void
-ffestd_R1221 (bool ok UNUSED)
-{
- assert (ffestd_block_level_ == 0);
-
- if (FFESTD_IS_END_OPTIMIZED_ && ffestd_is_reachable_)
- ffestd_R1227 (NULL); /* Generate RETURN. */
-
- if (ffestw_state (ffestw_stack_top ()) != FFESTV_stateFUNCTION5)
- ffestd_subr_labels_ (FALSE);/* Handle any undefined labels. */
-
-#if FFECOM_ONEPASS
- ffeste_R1221 ();
-#else
- {
- ffestdStmt_ stmt;
-
- stmt = ffestd_stmt_new_ (FFESTD_stmtidR1221_);
- ffestd_stmt_append_ (stmt);
- }
-#endif
-}
+ stmt = ffestd_stmt_new_ (FFESTD_stmtidR1221_);
+ ffestd_stmt_append_ (stmt);
+}
/* ffestd_R1223 -- SUBROUTINE statement
ffecom_notify_primary_entry (s);
ffestw_set_sym (ffestw_stack_top (), s);
-
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- fprintf (dmpout, "< SUBROUTINE %s ", ffelex_token_text (subrname));
- if (recursive)
- fputs ("recursive ", dmpout);
- if (args != NULL)
- {
- fputc ('(', dmpout);
- ffestt_tokenlist_dump (args);
- fputc (')', dmpout);
- }
- fputc ('\n', dmpout);
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
-#else
-#error
-#endif
}
/* ffestd_R1225 -- End a SUBROUTINE
void
ffestd_R1225 (bool ok UNUSED)
{
+ ffestdStmt_ stmt;
+
assert (ffestd_block_level_ == 0);
if (FFESTD_IS_END_OPTIMIZED_ && ffestd_is_reachable_)
if (ffestw_state (ffestw_stack_top ()) != FFESTV_stateSUBROUTINE5)
ffestd_subr_labels_ (FALSE);/* Handle any undefined labels. */
-#if FFECOM_ONEPASS
- ffeste_R1225 ();
-#else
- {
- ffestdStmt_ stmt;
-
- stmt = ffestd_stmt_new_ (FFESTD_stmtidR1225_);
- ffestd_stmt_append_ (stmt);
- }
-#endif
+ stmt = ffestd_stmt_new_ (FFESTD_stmtidR1225_);
+ ffestd_stmt_append_ (stmt);
}
/* ffestd_R1226 -- ENTRY statement
{
ffestd_check_simple_ ();
-#if (FFECOM_targetCURRENT == FFECOM_targetFFE) || FFECOM_ONEPASS
- ffestd_subr_line_now_ ();
- ffeste_R1226 (entry);
-#else
if (!ffesta_seen_first_exec || ffecom_2pass_advise_entrypoint (entry))
{
ffestdStmt_ stmt;
stmt->u.R1226.entry = entry;
stmt->u.R1226.entrynum = ++ffestd_2pass_entrypoints_;
}
-#endif
ffestd_is_reachable_ = TRUE;
}
void
ffestd_R1227 (ffebld expr)
{
+ ffestdStmt_ stmt;
+
ffestd_check_simple_ ();
-#if FFECOM_ONEPASS
- ffestd_subr_line_now_ ();
- ffeste_R1227 (ffestw_stack_top (), expr);
-#else
- {
- ffestdStmt_ stmt;
-
- stmt = ffestd_stmt_new_ (FFESTD_stmtidR1227_);
- ffestd_stmt_append_ (stmt);
- ffestd_subr_line_save_ (stmt);
- stmt->u.R1227.pool = ffesta_output_pool;
- stmt->u.R1227.block = ffestw_stack_top ();
- stmt->u.R1227.expr = expr;
- ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
- }
-#endif
+ stmt = ffestd_stmt_new_ (FFESTD_stmtidR1227_);
+ ffestd_stmt_append_ (stmt);
+ ffestd_subr_line_save_ (stmt);
+ stmt->u.R1227.pool = ffesta_output_pool;
+ stmt->u.R1227.block = ffestw_stack_top ();
+ stmt->u.R1227.expr = expr;
+ ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
if (ffestd_block_level_ == 0)
ffestd_is_reachable_ = FALSE;
ffestd_R1229_start (ffelexToken name UNUSED, ffesttTokenList args UNUSED)
{
ffestd_check_start_ ();
-
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
-#else
-#error
-#endif
}
/* ffestd_R1229_finish -- STMTFUNCTION statement list complete
void
ffestd_R1229_finish (ffesymbol s)
{
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- ffebld args = ffesymbol_dummyargs (s);
-#endif
ffebld expr = ffesymbol_sfexpr (s);
ffestd_check_finish_ ();
if (expr == NULL)
return; /* Nothing to do, definition didn't work. */
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- fprintf (dmpout, "* stmtfunction %s(", ffesymbol_text (s));
- for (; args != NULL; args = ffebld_trail (args))
- fprintf (dmpout, "%s,", ffesymbol_text (ffebld_symter (ffebld_head (args))));
- fputs (")=", dmpout);
- ffebld_dump (expr);
- fputc ('\n', dmpout);
-#if 0 /* Normally no need to preserve the
- expression. */
- ffesymbol_set_sfexpr (s, NULL); /* Except expr.c sees NULL
- as recursive reference!
- So until we can use something
- convenient, like a "permanent"
- expression, don't worry about
- wasting some memory in the
- stand-alone FFE. */
-#else
- ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
-#endif
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
/* With gcc, cannot do anything here, because the backend hasn't even
(necessarily) been notified that we're compiling a program unit! */
-
-#if 0 /* Must preserve the expression for gcc. */
- ffesymbol_set_sfexpr (s, NULL);
-#else
ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
-#endif
-#else
-#error
-#endif
}
/* ffestd_S3P4 -- INCLUDE line
ffestd_V003_start (ffelexToken structure_name)
{
ffestd_check_start_ ();
-
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- if (structure_name == NULL)
- fputs ("* STRUCTURE_unnamed ", dmpout);
- else
- fprintf (dmpout, "* STRUCTURE %s ", ffelex_token_text (structure_name));
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
ffestd_subr_vxt_ ();
-#else
-#error
-#endif
}
/* ffestd_V003_item -- STRUCTURE statement for object-name
ffestd_V003_item (ffelexToken name, ffesttDimList dims)
{
ffestd_check_item_ ();
-
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- fputs (ffelex_token_text (name), dmpout);
- if (dims != NULL)
- {
- fputc ('(', dmpout);
- ffestt_dimlist_dump (dims);
- fputc (')', dmpout);
- }
- fputc (',', dmpout);
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
-#else
-#error
-#endif
}
/* ffestd_V003_finish -- STRUCTURE statement list complete
ffestd_V003_finish ()
{
ffestd_check_finish_ ();
-
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- fputc ('\n', dmpout);
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
-#else
-#error
-#endif
}
/* ffestd_V004 -- End a STRUCTURE
void
ffestd_V004 (bool ok)
{
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- fputs ("* END_STRUCTURE\n", dmpout);
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
-#else
-#error
-#endif
}
/* ffestd_V009 -- UNION statement
ffestd_V009 ()
{
ffestd_check_simple_ ();
-
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- fputs ("* UNION\n", dmpout);
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
-#else
-#error
-#endif
}
/* ffestd_V010 -- End a UNION
void
ffestd_V010 (bool ok)
{
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- fputs ("* END_UNION\n", dmpout);
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
-#else
-#error
-#endif
}
/* ffestd_V012 -- MAP statement
ffestd_V012 ()
{
ffestd_check_simple_ ();
-
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- fputs ("* MAP\n", dmpout);
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
-#else
-#error
-#endif
}
/* ffestd_V013 -- End a MAP
void
ffestd_V013 (bool ok)
{
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- fputs ("* END_MAP\n", dmpout);
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
-#else
-#error
-#endif
}
#endif
ffestd_V014_start ()
{
ffestd_check_start_ ();
-
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- fputs ("* VOLATILE (", dmpout);
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
- ffestd_subr_vxt_ ();
-#else
-#error
-#endif
}
/* ffestd_V014_item_object -- VOLATILE statement for object-name
ffestd_V014_item_object (ffelexToken name UNUSED)
{
ffestd_check_item_ ();
-
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- fprintf (dmpout, "%s,", ffelex_token_text (name));
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
-#else
-#error
-#endif
}
/* ffestd_V014_item_cblock -- VOLATILE statement for common-block-name
ffestd_V014_item_cblock (ffelexToken name UNUSED)
{
ffestd_check_item_ ();
-
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- fprintf (dmpout, "/%s/,", ffelex_token_text (name));
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
-#else
-#error
-#endif
}
/* ffestd_V014_finish -- VOLATILE statement list complete
ffestd_V014_finish ()
{
ffestd_check_finish_ ();
-
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- fputs (")\n", dmpout);
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
-#else
-#error
-#endif
}
/* ffestd_V016_start -- RECORD statement list begin
ffestd_V016_start ()
{
ffestd_check_start_ ();
-
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- fputs ("* RECORD ", dmpout);
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
- ffestd_subr_vxt_ ();
-#else
-#error
-#endif
}
/* ffestd_V016_item_structure -- RECORD statement for common-block-name
ffestd_V016_item_structure (ffelexToken name)
{
ffestd_check_item_ ();
-
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- fprintf (dmpout, "/%s/,", ffelex_token_text (name));
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
-#else
-#error
-#endif
}
/* ffestd_V016_item_object -- RECORD statement for object-name
ffestd_V016_item_object (ffelexToken name, ffesttDimList dims)
{
ffestd_check_item_ ();
-
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- fputs (ffelex_token_text (name), dmpout);
- if (dims != NULL)
- {
- fputc ('(', dmpout);
- ffestt_dimlist_dump (dims);
- fputc (')', dmpout);
- }
- fputc (',', dmpout);
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
-#else
-#error
-#endif
}
/* ffestd_V016_finish -- RECORD statement list complete
ffestd_V016_finish ()
{
ffestd_check_finish_ ();
-
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- fputc ('\n', dmpout);
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
-#else
-#error
-#endif
}
/* ffestd_V018_start -- REWRITE(...) statement list begin
ffestd_V018_start (ffestvFormat format)
{
ffestd_check_start_ ();
-
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
-
-#if FFECOM_ONEPASS
- ffestd_subr_line_now_ ();
- ffeste_V018_start (&ffestp_file.rewrite, format);
-#else
- {
- ffestdStmt_ stmt;
-
- stmt = ffestd_stmt_new_ (FFESTD_stmtidV018_);
- ffestd_stmt_append_ (stmt);
- ffestd_subr_line_save_ (stmt);
- stmt->u.V018.pool = ffesta_output_pool;
- stmt->u.V018.params = ffestd_subr_copy_rewrite_ ();
- stmt->u.V018.format = format;
- stmt->u.V018.list = NULL;
- ffestd_expr_list_ = &stmt->u.V018.list;
- ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
- }
-#endif
-
-#endif
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
ffestd_subr_vxt_ ();
-#endif
}
/* ffestd_V018_item -- REWRITE statement i/o item
ffestd_V018_item (ffebld expr)
{
ffestd_check_item_ ();
-
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
-
-#if FFECOM_ONEPASS
- ffeste_V018_item (expr);
-#else
- {
- ffestdExprItem_ item
- = (ffestdExprItem_) malloc_new_kp (ffesta_output_pool, "ffestdExprItem_",
- sizeof (*item));
-
- item->next = NULL;
- item->expr = expr;
- *ffestd_expr_list_ = item;
- ffestd_expr_list_ = &item->next;
- }
-#endif
-
-#endif
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
-#endif
}
/* ffestd_V018_finish -- REWRITE statement list complete
ffestd_V018_finish ()
{
ffestd_check_finish_ ();
-
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
-
-#if FFECOM_ONEPASS
- ffeste_V018_finish ();
-#else
- /* Nothing to do, it's implicit. */
-#endif
-
-#endif
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
-#endif
}
/* ffestd_V019_start -- ACCEPT statement list begin
ffestd_V019_start (ffestvFormat format)
{
ffestd_check_start_ ();
-
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
-
-#if FFECOM_ONEPASS
- ffestd_subr_line_now_ ();
- ffeste_V019_start (&ffestp_file.accept, format);
-#else
- {
- ffestdStmt_ stmt;
-
- stmt = ffestd_stmt_new_ (FFESTD_stmtidV019_);
- ffestd_stmt_append_ (stmt);
- ffestd_subr_line_save_ (stmt);
- stmt->u.V019.pool = ffesta_output_pool;
- stmt->u.V019.params = ffestd_subr_copy_accept_ ();
- stmt->u.V019.format = format;
- stmt->u.V019.list = NULL;
- ffestd_expr_list_ = &stmt->u.V019.list;
- ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
- }
-#endif
-
-#endif
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
ffestd_subr_vxt_ ();
-#endif
}
/* ffestd_V019_item -- ACCEPT statement i/o item
ffestd_V019_item (ffebld expr)
{
ffestd_check_item_ ();
-
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
-
-#if FFECOM_ONEPASS
- ffeste_V019_item (expr);
-#else
- {
- ffestdExprItem_ item
- = (ffestdExprItem_) malloc_new_kp (ffesta_output_pool, "ffestdExprItem_",
- sizeof (*item));
-
- item->next = NULL;
- item->expr = expr;
- *ffestd_expr_list_ = item;
- ffestd_expr_list_ = &item->next;
- }
-#endif
-
-#endif
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
-#endif
}
/* ffestd_V019_finish -- ACCEPT statement list complete
ffestd_V019_finish ()
{
ffestd_check_finish_ ();
-
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
-
-#if FFECOM_ONEPASS
- ffeste_V019_finish ();
-#else
- /* Nothing to do, it's implicit. */
-#endif
-
-#endif
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
-#endif
}
#endif
ffestd_V020_start (ffestvFormat format UNUSED)
{
ffestd_check_start_ ();
-
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
-
-#if FFECOM_ONEPASS
- ffestd_subr_line_now_ ();
- ffeste_V020_start (&ffestp_file.type, format);
-#else
- {
- ffestdStmt_ stmt;
-
- stmt = ffestd_stmt_new_ (FFESTD_stmtidV020_);
- ffestd_stmt_append_ (stmt);
- ffestd_subr_line_save_ (stmt);
- stmt->u.V020.pool = ffesta_output_pool;
- stmt->u.V020.params = ffestd_subr_copy_type_ ();
- stmt->u.V020.format = format;
- stmt->u.V020.list = NULL;
- ffestd_expr_list_ = &stmt->u.V020.list;
- ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
- }
-#endif
-
-#endif
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
ffestd_subr_vxt_ ();
-#endif
}
/* ffestd_V020_item -- TYPE statement i/o item
ffestd_V020_item (ffebld expr UNUSED)
{
ffestd_check_item_ ();
-
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
-
-#if FFECOM_ONEPASS
- ffeste_V020_item (expr);
-#else
- {
- ffestdExprItem_ item
- = (ffestdExprItem_) malloc_new_kp (ffesta_output_pool, "ffestdExprItem_",
- sizeof (*item));
-
- item->next = NULL;
- item->expr = expr;
- *ffestd_expr_list_ = item;
- ffestd_expr_list_ = &item->next;
- }
-#endif
-
-#endif
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
-#endif
}
/* ffestd_V020_finish -- TYPE statement list complete
ffestd_V020_finish ()
{
ffestd_check_finish_ ();
-
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
-
-#if FFECOM_ONEPASS
- ffeste_V020_finish ();
-#else
- /* Nothing to do, it's implicit. */
-#endif
-
-#endif
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
-#endif
}
/* ffestd_V021 -- DELETE statement
ffestd_V021 ()
{
ffestd_check_simple_ ();
-
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
-
-#if FFECOM_ONEPASS
- ffestd_subr_line_now_ ();
- ffeste_V021 (&ffestp_file.delete);
-#else
- {
- ffestdStmt_ stmt;
-
- stmt = ffestd_stmt_new_ (FFESTD_stmtidV021_);
- ffestd_stmt_append_ (stmt);
- ffestd_subr_line_save_ (stmt);
- stmt->u.V021.pool = ffesta_output_pool;
- stmt->u.V021.params = ffestd_subr_copy_delete_ ();
- ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
- }
-#endif
-
-#endif
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
ffestd_subr_vxt_ ();
-#endif
}
/* ffestd_V022 -- UNLOCK statement
ffestd_V022 ()
{
ffestd_check_simple_ ();
-
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
-
-#if FFECOM_ONEPASS
- ffestd_subr_line_now_ ();
- ffeste_V022 (&ffestp_file.beru);
-#else
- {
- ffestdStmt_ stmt;
-
- stmt = ffestd_stmt_new_ (FFESTD_stmtidV022_);
- ffestd_stmt_append_ (stmt);
- ffestd_subr_line_save_ (stmt);
- stmt->u.V022.pool = ffesta_output_pool;
- stmt->u.V022.params = ffestd_subr_copy_beru_ ();
- ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
- }
-#endif
-
-#endif
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
ffestd_subr_vxt_ ();
-#endif
}
/* ffestd_V023_start -- ENCODE(...) statement list begin
ffestd_V023_start ()
{
ffestd_check_start_ ();
-
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
-
-#if FFECOM_ONEPASS
- ffestd_subr_line_now_ ();
- ffeste_V023_start (&ffestp_file.vxtcode);
-#else
- {
- ffestdStmt_ stmt;
-
- stmt = ffestd_stmt_new_ (FFESTD_stmtidV023_);
- ffestd_stmt_append_ (stmt);
- ffestd_subr_line_save_ (stmt);
- stmt->u.V023.pool = ffesta_output_pool;
- stmt->u.V023.params = ffestd_subr_copy_vxtcode_ ();
- stmt->u.V023.list = NULL;
- ffestd_expr_list_ = &stmt->u.V023.list;
- ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
- }
-#endif
-
-#endif
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
ffestd_subr_vxt_ ();
-#endif
}
/* ffestd_V023_item -- ENCODE statement i/o item
ffestd_V023_item (ffebld expr)
{
ffestd_check_item_ ();
-
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
-
-#if FFECOM_ONEPASS
- ffeste_V023_item (expr);
-#else
- {
- ffestdExprItem_ item
- = (ffestdExprItem_) malloc_new_kp (ffesta_output_pool, "ffestdExprItem_",
- sizeof (*item));
-
- item->next = NULL;
- item->expr = expr;
- *ffestd_expr_list_ = item;
- ffestd_expr_list_ = &item->next;
- }
-#endif
-
-#endif
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
-#endif
}
/* ffestd_V023_finish -- ENCODE statement list complete
ffestd_V023_finish ()
{
ffestd_check_finish_ ();
-
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
-
-#if FFECOM_ONEPASS
- ffeste_V023_finish ();
-#else
- /* Nothing to do, it's implicit. */
-#endif
-
-#endif
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
-#endif
}
/* ffestd_V024_start -- DECODE(...) statement list begin
ffestd_V024_start ()
{
ffestd_check_start_ ();
-
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
-
-#if FFECOM_ONEPASS
- ffestd_subr_line_now_ ();
- ffeste_V024_start (&ffestp_file.vxtcode);
-#else
- {
- ffestdStmt_ stmt;
-
- stmt = ffestd_stmt_new_ (FFESTD_stmtidV024_);
- ffestd_stmt_append_ (stmt);
- ffestd_subr_line_save_ (stmt);
- stmt->u.V024.pool = ffesta_output_pool;
- stmt->u.V024.params = ffestd_subr_copy_vxtcode_ ();
- stmt->u.V024.list = NULL;
- ffestd_expr_list_ = &stmt->u.V024.list;
- ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
- }
-#endif
-
-#endif
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
ffestd_subr_vxt_ ();
-#endif
}
/* ffestd_V024_item -- DECODE statement i/o item
ffestd_V024_item (ffebld expr)
{
ffestd_check_item_ ();
-
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
-
-#if FFECOM_ONEPASS
- ffeste_V024_item (expr);
-#else
- {
- ffestdExprItem_ item
- = (ffestdExprItem_) malloc_new_kp (ffesta_output_pool, "ffestdExprItem_",
- sizeof (*item));
-
- item->next = NULL;
- item->expr = expr;
- *ffestd_expr_list_ = item;
- ffestd_expr_list_ = &item->next;
- }
-#endif
-
-#endif
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
-#endif
}
/* ffestd_V024_finish -- DECODE statement list complete
ffestd_V024_finish ()
{
ffestd_check_finish_ ();
-
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
-
-#if FFECOM_ONEPASS
- ffeste_V024_finish ();
-#else
- /* Nothing to do, it's implicit. */
-#endif
-
-#endif
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
-#endif
}
/* ffestd_V025_start -- DEFINEFILE statement list begin
ffestd_V025_start ()
{
ffestd_check_start_ ();
-
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
-
-#if FFECOM_ONEPASS
- ffestd_subr_line_now_ ();
- ffeste_V025_start ();
-#else
- {
- ffestdStmt_ stmt;
-
- stmt = ffestd_stmt_new_ (FFESTD_stmtidV025start_);
- ffestd_stmt_append_ (stmt);
- ffestd_subr_line_save_ (stmt);
- ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
- }
-#endif
-
-#endif
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
ffestd_subr_vxt_ ();
-#endif
}
/* ffestd_V025_item -- DEFINE FILE statement item
ffestd_V025_item (ffebld u, ffebld m, ffebld n, ffebld asv)
{
ffestd_check_item_ ();
-
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
-
-#if FFECOM_ONEPASS
- ffeste_V025_item (u, m, n, asv);
-#else
- {
- ffestdStmt_ stmt;
-
- stmt = ffestd_stmt_new_ (FFESTD_stmtidV025item_);
- ffestd_stmt_append_ (stmt);
- stmt->u.V025item.u = u;
- stmt->u.V025item.m = m;
- stmt->u.V025item.n = n;
- stmt->u.V025item.asv = asv;
- }
-#endif
-
-#endif
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
-#endif
}
/* ffestd_V025_finish -- DEFINE FILE statement list complete
ffestd_V025_finish ()
{
ffestd_check_finish_ ();
-
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
-
-#if FFECOM_ONEPASS
- ffeste_V025_finish ();
-#else
- {
- ffestdStmt_ stmt;
-
- stmt = ffestd_stmt_new_ (FFESTD_stmtidV025finish_);
- stmt->u.V025finish.pool = ffesta_output_pool;
- ffestd_stmt_append_ (stmt);
- }
-#endif
-
-#endif
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
-#endif
}
/* ffestd_V026 -- FIND statement
ffestd_V026 ()
{
ffestd_check_simple_ ();
-
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
-
-#if FFECOM_ONEPASS
- ffestd_subr_line_now_ ();
- ffeste_V026 (&ffestp_file.find);
-#else
- {
- ffestdStmt_ stmt;
-
- stmt = ffestd_stmt_new_ (FFESTD_stmtidV026_);
- ffestd_stmt_append_ (stmt);
- ffestd_subr_line_save_ (stmt);
- stmt->u.V026.pool = ffesta_output_pool;
- stmt->u.V026.params = ffestd_subr_copy_find_ ();
- ffesta_set_outpooldisp (FFESTA_pooldispPRESERVE);
- }
-#endif
-
-#endif
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
ffestd_subr_vxt_ ();
-#endif
}
#endif
ffestd_V027_start ()
{
ffestd_check_start_ ();
-
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- fputs ("* PARAMETER_vxt ", dmpout);
-#else
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
ffestd_subr_vxt_ ();
-#endif
-#endif
}
/* ffestd_V027_item -- VXT PARAMETER statement assignment
ffestd_V027_item (ffelexToken dest_token UNUSED, ffebld source UNUSED)
{
ffestd_check_item_ ();
-
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- fputs (ffelex_token_text (dest_token), dmpout);
- fputc ('=', dmpout);
- ffebld_dump (source);
- fputc (',', dmpout);
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
-#else
-#error
-#endif
}
/* ffestd_V027_finish -- VXT PARAMETER statement list complete
ffestd_V027_finish ()
{
ffestd_check_finish_ ();
-
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- fputc ('\n', dmpout);
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
-#else
-#error
-#endif
}
/* Any executable statement. */
void
ffestd_any ()
{
- ffestd_check_simple_ ();
+ ffestdStmt_ stmt;
-#if FFECOM_ONEPASS
- ffestd_subr_line_now_ ();
- ffeste_R841 ();
-#else
- {
- ffestdStmt_ stmt;
+ ffestd_check_simple_ ();
- stmt = ffestd_stmt_new_ (FFESTD_stmtidR841_);
- ffestd_stmt_append_ (stmt);
- ffestd_subr_line_save_ (stmt);
- }
-#endif
+ stmt = ffestd_stmt_new_ (FFESTD_stmtidR841_);
+ ffestd_stmt_append_ (stmt);
+ ffestd_subr_line_save_ (stmt);
}
/* Include files. */
#include "proj.h"
-
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
#include "rtl.h"
#include "toplev.h"
#include "ggc.h"
-#endif
-
#include "ste.h"
#include "bld.h"
#include "com.h"
/* Static objects accessed by functions in this module. */
static ffesteStatelet_ ffeste_statelet_ = FFESTE_stateletSIMPLE_;
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
static ffelab ffeste_label_formatdef_ = NULL;
static tree (*ffeste_io_driver_) (ffebld expr); /* do?io. */
static ffecomGfrt ffeste_io_endgfrt_; /* end function to call. */
static tree ffeste_io_err_; /* ERR= label or NULL_TREE. */
static tree ffeste_io_iostat_; /* IOSTAT= var or NULL_TREE. */
static bool ffeste_io_iostat_is_temp_; /* IOSTAT= var is a temp. */
-#endif
/* Static functions (internal). */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
static void ffeste_begin_iterdo_ (ffestw block, tree *tvar, tree *tincr,
tree *xitersvar, ffebld var,
ffebld start, ffelexToken start_token,
ffestpFile *recl_spec,
ffestpFile *blank_spec);
static void ffeste_subr_beru_ (ffestpBeruStmt *info, ffecomGfrt rt);
-#elif FFECOM_targetCURRENT == FFECOM_targetFFE
-static void ffeste_subr_file_ (const char *kw, ffestpFile *spec);
-#else
-#error
-#endif
/* Internal macros. */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
#define ffeste_emit_line_note_() \
emit_line_note (input_filename, lineno)
-#endif
#define ffeste_check_simple_() \
assert(ffeste_statelet_ == FFESTE_stateletSIMPLE_)
#define ffeste_check_start_() \
/* Begin an iterative DO loop. Pass the block to start if
applicable. */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
static void
ffeste_begin_iterdo_ (ffestw block, tree *xtvar, tree *xtincr,
tree *xitersvar, ffebld var,
}
}
-#endif
-
/* End an iterative DO loop. Pass the same iteration variable and increment
value trees that were generated in the paired _begin_ call. */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
static void
ffeste_end_iterdo_ (ffestw block, tree tvar, tree tincr, tree itersvar)
{
else
ffeste_end_stmt_ ();
}
-#endif
/* Generate call to run-time I/O routine. */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
static void
ffeste_io_call_ (tree call, bool do_check)
{
expand_goto (ffeste_io_abort_);
expand_end_cond ();
}
-#endif
/* Handle implied-DO in I/O list.
DO loop, handles appropriately (possibly including recursively calling
itself). Then expands code to end the DO loop. */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
static void
ffeste_io_impdo_ (ffebld impdo, ffelexToken impdo_token)
{
ffeste_end_iterdo_ (NULL, tvar, tincr, titervar);
}
-#endif
/* I/O driver for formatted I/O item (do_fio)
of the result to an IOSTAT= variable, and emit any checking of the
result for errors. */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
static tree
ffeste_io_dofio_ (ffebld expr)
{
return ffecom_call_gfrt (FFECOM_gfrtDOFIO, arglist, NULL_TREE);
}
-#endif
/* I/O driver for list-directed I/O item (do_lio)
Returns a tree for a CALL_EXPR to the do_lio function, which handles
of the result to an IOSTAT= variable, and emit any checking of the
result for errors. */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
static tree
ffeste_io_dolio_ (ffebld expr)
{
return ffecom_call_gfrt (FFECOM_gfrtDOLIO, arglist, NULL_TREE);
}
-#endif
/* I/O driver for unformatted I/O item (do_uio)
Returns a tree for a CALL_EXPR to the do_uio function, which handles
of the result to an IOSTAT= variable, and emit any checking of the
result for errors. */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
static tree
ffeste_io_douio_ (ffebld expr)
{
return ffecom_call_gfrt (FFECOM_gfrtDOUIO, arglist, NULL_TREE);
}
-#endif
/* Make arglist with ptr to BACKSPACE/ENDFILE/REWIND control list.
Returns a tree suitable as an argument list containing a pointer to
declaration of variables (temporaries) to the expanding of expressions,
statements, etc. */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
static tree
ffeste_io_ialist_ (bool have_err,
ffestvUnit unit,
return t;
}
-#endif
/* Make arglist with ptr to external-I/O control list.
Returns a tree suitable as an argument list containing a pointer to
declaration of variables (temporaries) to the expanding of expressions,
statements, etc. */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
static tree
ffeste_io_cilist_ (bool have_err,
ffestvUnit unit,
return t;
}
-#endif
/* Make arglist with ptr to CLOSE control list.
Returns a tree suitable as an argument list containing a pointer to
declaration of variables (temporaries) to the expanding of expressions,
statements, etc. */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
static tree
ffeste_io_cllist_ (bool have_err,
ffebld unit_expr,
return t;
}
-#endif
/* Make arglist with ptr to internal-I/O control list.
Returns a tree suitable as an argument list containing a pointer to
declaration of variables (temporaries) to the expanding of expressions,
statements, etc. */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
static tree
ffeste_io_icilist_ (bool have_err,
ffebld unit_expr,
{
int need_unitexp = (! unitexp);
int need_unitlenexp = (! unitlenexp);
-
+
unitexp = ffecom_arg_ptr_to_expr (unit_expr, &unitlenexp);
if (need_unitexp)
ffeste_f2c_compile_ (unitfield, unitexp);
return t;
}
-#endif
/* Make arglist with ptr to INQUIRE control list
declaration of variables (temporaries) to the expanding of expressions,
statements, etc. */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
static tree
ffeste_io_inlist_ (bool have_err,
ffestpFile *unit_spec,
return t;
}
-#endif
/* Make arglist with ptr to OPEN control list
Returns a tree suitable as an argument list containing a pointer to
declaration of variables (temporaries) to the expanding of expressions,
statements, etc. */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
static tree
ffeste_io_olist_ (bool have_err,
ffebld unit_expr,
return t;
}
-#endif
-/* Display file-statement specifier. */
-
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
-static void
-ffeste_subr_file_ (const char *kw, ffestpFile *spec)
-{
- if (!spec->kw_or_val_present)
- return;
- fputs (kw, dmpout);
- if (spec->value_present)
- {
- fputc ('=', dmpout);
- if (spec->value_is_label)
- {
- assert (spec->value_is_label == 2); /* Temporary checking only. */
- fprintf (dmpout, "%" ffelabValue_f "u",
- ffelab_value (spec->u.label));
- }
- else
- ffebld_dump (spec->u.expr);
- }
- fputc (',', dmpout);
-}
-#endif
-
/* Generate code for BACKSPACE/ENDFILE/REWIND. */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
static void
ffeste_subr_beru_ (ffestpBeruStmt *info, ffecomGfrt rt)
{
ffeste_end_stmt_ ();
}
-#endif
/* END DO statement
void
ffeste_do (ffestw block)
{
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- fputs ("+ END_DO\n", dmpout);
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
ffeste_emit_line_note_ ();
if (ffestw_do_tvar (block) == 0)
ffestw_do_tvar (block),
ffestw_do_incr_saved (block),
ffestw_do_count_var (block));
-#else
-#error
-#endif
}
/* End of statement following logical IF.
void
ffeste_end_R807 ()
{
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- fputs ("+ END_IF\n", dmpout); /* Also see ffeste_R806. */
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
ffeste_emit_line_note_ ();
expand_end_cond ();
ffeste_end_block_ (NULL);
-#else
-#error
-#endif
}
/* Generate "code" for branch label definition. */
void
ffeste_labeldef_branch (ffelab label)
{
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- fprintf (dmpout, "+ label %lu\n", ffelab_value (label));
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
- {
- tree glabel;
+ tree glabel;
- glabel = ffecom_lookup_label (label);
- assert (glabel != NULL_TREE);
- if (TREE_CODE (glabel) == ERROR_MARK)
- return;
+ glabel = ffecom_lookup_label (label);
+ assert (glabel != NULL_TREE);
+ if (TREE_CODE (glabel) == ERROR_MARK)
+ return;
- assert (DECL_INITIAL (glabel) == NULL_TREE);
+ assert (DECL_INITIAL (glabel) == NULL_TREE);
- DECL_INITIAL (glabel) = error_mark_node;
- DECL_SOURCE_FILE (glabel) = ffelab_definition_filename (label);
- DECL_SOURCE_LINE (glabel) = ffelab_definition_filelinenum (label);
+ DECL_INITIAL (glabel) = error_mark_node;
+ DECL_SOURCE_FILE (glabel) = ffelab_definition_filename (label);
+ DECL_SOURCE_LINE (glabel) = ffelab_definition_filelinenum (label);
- emit_nop ();
+ emit_nop ();
- expand_label (glabel);
- }
-#else
-#error
-#endif
+ expand_label (glabel);
}
/* Generate "code" for FORMAT label definition. */
void
ffeste_labeldef_format (ffelab label)
{
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- fprintf (dmpout, "$ label %lu\n", ffelab_value (label));
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
ffeste_label_formatdef_ = label;
-#else
-#error
-#endif
}
/* Assignment statement (outside of WHERE). */
{
ffeste_check_simple_ ();
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- fputs ("+ let ", dmpout);
- ffebld_dump (dest);
- fputs ("=", dmpout);
- ffebld_dump (source);
- fputc ('\n', dmpout);
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
ffeste_emit_line_note_ ();
ffeste_start_stmt_ ();
ffecom_expand_let_stmt (dest, source);
ffeste_end_stmt_ ();
-#else
-#error
-#endif
}
/* Block IF (IF-THEN) statement. */
void
ffeste_R803 (ffestw block, ffebld expr)
{
- ffeste_check_simple_ ();
+ tree temp;
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- fputs ("+ IF_block (", dmpout);
- ffebld_dump (expr);
- fputs (")\n", dmpout);
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
- {
- tree temp;
+ ffeste_check_simple_ ();
- ffeste_emit_line_note_ ();
+ ffeste_emit_line_note_ ();
- ffeste_start_block_ (block);
+ ffeste_start_block_ (block);
- temp = ffecom_make_tempvar ("ifthen", integer_type_node,
- FFETARGET_charactersizeNONE, -1);
+ temp = ffecom_make_tempvar ("ifthen", integer_type_node,
+ FFETARGET_charactersizeNONE, -1);
- ffeste_start_stmt_ ();
+ ffeste_start_stmt_ ();
- ffecom_prepare_expr (expr);
+ ffecom_prepare_expr (expr);
- if (ffecom_prepare_end ())
- {
- tree result;
+ if (ffecom_prepare_end ())
+ {
+ tree result;
- result = ffecom_modify (void_type_node,
- temp,
- ffecom_truth_value (ffecom_expr (expr)));
+ result = ffecom_modify (void_type_node,
+ temp,
+ ffecom_truth_value (ffecom_expr (expr)));
- expand_expr_stmt (result);
+ expand_expr_stmt (result);
- ffeste_end_stmt_ ();
- }
- else
- {
- ffeste_end_stmt_ ();
+ ffeste_end_stmt_ ();
+ }
+ else
+ {
+ ffeste_end_stmt_ ();
- temp = ffecom_truth_value (ffecom_expr (expr));
- }
+ temp = ffecom_truth_value (ffecom_expr (expr));
+ }
- expand_start_cond (temp, 0);
+ expand_start_cond (temp, 0);
- /* No fake `else' constructs introduced (yet). */
- ffestw_set_ifthen_fake_else (block, 0);
- }
-#else
-#error
-#endif
+ /* No fake `else' constructs introduced (yet). */
+ ffestw_set_ifthen_fake_else (block, 0);
}
/* ELSE IF statement. */
void
ffeste_R804 (ffestw block, ffebld expr)
{
- ffeste_check_simple_ ();
+ tree temp;
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- fputs ("+ ELSE_IF (", dmpout);
- ffebld_dump (expr);
- fputs (")\n", dmpout);
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
- {
- tree temp;
+ ffeste_check_simple_ ();
- ffeste_emit_line_note_ ();
+ ffeste_emit_line_note_ ();
- /* Since ELSEIF(expr) might require preparations for expr,
- implement as ELSE; prepare-expr; IF (expr) THEN ...; ENDIF. */
+ /* Since ELSEIF(expr) might require preparations for expr,
+ implement as ELSE; prepare-expr; IF (expr) THEN ...; ENDIF. */
- expand_start_else ();
+ expand_start_else ();
- ffeste_start_block_ (block);
+ ffeste_start_block_ (block);
- temp = ffecom_make_tempvar ("elseif", integer_type_node,
- FFETARGET_charactersizeNONE, -1);
+ temp = ffecom_make_tempvar ("elseif", integer_type_node,
+ FFETARGET_charactersizeNONE, -1);
- ffeste_start_stmt_ ();
+ ffeste_start_stmt_ ();
- ffecom_prepare_expr (expr);
+ ffecom_prepare_expr (expr);
- if (ffecom_prepare_end ())
- {
- tree result;
+ if (ffecom_prepare_end ())
+ {
+ tree result;
- result = ffecom_modify (void_type_node,
- temp,
- ffecom_truth_value (ffecom_expr (expr)));
+ result = ffecom_modify (void_type_node,
+ temp,
+ ffecom_truth_value (ffecom_expr (expr)));
- expand_expr_stmt (result);
+ expand_expr_stmt (result);
- ffeste_end_stmt_ ();
- }
- else
- {
- /* In this case, we could probably have used expand_start_elseif
- instead, saving the need for a fake `else' construct. But,
- until it's clear that'd improve performance, it's easier this
- way, since we have to expand_start_else before we get to this
- test, given the current design. */
+ ffeste_end_stmt_ ();
+ }
+ else
+ {
+ /* In this case, we could probably have used expand_start_elseif
+ instead, saving the need for a fake `else' construct. But,
+ until it's clear that'd improve performance, it's easier this
+ way, since we have to expand_start_else before we get to this
+ test, given the current design. */
- ffeste_end_stmt_ ();
+ ffeste_end_stmt_ ();
- temp = ffecom_truth_value (ffecom_expr (expr));
- }
+ temp = ffecom_truth_value (ffecom_expr (expr));
+ }
- expand_start_cond (temp, 0);
+ expand_start_cond (temp, 0);
- /* Increment number of fake `else' constructs introduced. */
- ffestw_set_ifthen_fake_else (block,
- ffestw_ifthen_fake_else (block) + 1);
- }
-#else
-#error
-#endif
+ /* Increment number of fake `else' constructs introduced. */
+ ffestw_set_ifthen_fake_else (block,
+ ffestw_ifthen_fake_else (block) + 1);
}
/* ELSE statement. */
{
ffeste_check_simple_ ();
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- fputs ("+ ELSE\n", dmpout);
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
ffeste_emit_line_note_ ();
expand_start_else ();
-#else
-#error
-#endif
}
/* END IF statement. */
void
ffeste_R806 (ffestw block)
{
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- fputs ("+ END_IF_then\n", dmpout); /* Also see ffeste_shriek_if_. */
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
- {
- int i = ffestw_ifthen_fake_else (block) + 1;
+ int i = ffestw_ifthen_fake_else (block) + 1;
- ffeste_emit_line_note_ ();
+ ffeste_emit_line_note_ ();
- for (; i; --i)
- {
- expand_end_cond ();
+ for (; i; --i)
+ {
+ expand_end_cond ();
- ffeste_end_block_ (block);
- }
- }
-#else
-#error
-#endif
+ ffeste_end_block_ (block);
+ }
}
/* Logical IF statement. */
void
ffeste_R807 (ffebld expr)
{
- ffeste_check_simple_ ();
+ tree temp;
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- fputs ("+ IF_logical (", dmpout);
- ffebld_dump (expr);
- fputs (")\n", dmpout);
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
- {
- tree temp;
+ ffeste_check_simple_ ();
- ffeste_emit_line_note_ ();
+ ffeste_emit_line_note_ ();
- ffeste_start_block_ (NULL);
+ ffeste_start_block_ (NULL);
- temp = ffecom_make_tempvar ("if", integer_type_node,
- FFETARGET_charactersizeNONE, -1);
+ temp = ffecom_make_tempvar ("if", integer_type_node,
+ FFETARGET_charactersizeNONE, -1);
- ffeste_start_stmt_ ();
+ ffeste_start_stmt_ ();
- ffecom_prepare_expr (expr);
+ ffecom_prepare_expr (expr);
- if (ffecom_prepare_end ())
- {
- tree result;
+ if (ffecom_prepare_end ())
+ {
+ tree result;
- result = ffecom_modify (void_type_node,
- temp,
- ffecom_truth_value (ffecom_expr (expr)));
+ result = ffecom_modify (void_type_node,
+ temp,
+ ffecom_truth_value (ffecom_expr (expr)));
- expand_expr_stmt (result);
+ expand_expr_stmt (result);
- ffeste_end_stmt_ ();
- }
- else
- {
- ffeste_end_stmt_ ();
+ ffeste_end_stmt_ ();
+ }
+ else
+ {
+ ffeste_end_stmt_ ();
- temp = ffecom_truth_value (ffecom_expr (expr));
- }
+ temp = ffecom_truth_value (ffecom_expr (expr));
+ }
- expand_start_cond (temp, 0);
- }
-#else
-#error
-#endif
+ expand_start_cond (temp, 0);
}
/* SELECT CASE statement. */
{
ffeste_check_simple_ ();
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- fputs ("+ SELECT_CASE (", dmpout);
- ffebld_dump (expr);
- fputs (")\n", dmpout);
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
ffeste_emit_line_note_ ();
ffeste_start_block_ (block);
ffestw_set_select_texpr (block, texpr);
ffestw_set_select_break (block, FALSE);
}
-#else
-#error
-#endif
}
/* CASE statement.
{
ffestwSelect s = ffestw_select (block);
ffestwCase c;
+ tree texprlow;
+ tree texprhigh;
+ tree tlabel;
+ int pushok;
+ tree duplicate;
ffeste_check_simple_ ();
else
c = s->first_stmt;
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- if ((c == NULL) || (casenum != c->casenum))
- {
- if (casenum == 0) /* Intentional CASE DEFAULT. */
- fputs ("+ CASE_DEFAULT", dmpout);
- }
- else
- {
- bool comma = FALSE;
-
- fputs ("+ CASE (", dmpout);
- do
- {
- if (comma)
- fputc (',', dmpout);
- else
- comma = TRUE;
- if (c->low != NULL)
- ffebld_constant_dump (c->low);
- if (c->low != c->high)
- {
- fputc (':', dmpout);
- if (c->high != NULL)
- ffebld_constant_dump (c->high);
- }
- c = c->next_stmt;
- /* Unlink prev. */
- c->previous_stmt->previous_stmt->next_stmt = c;
- c->previous_stmt = c->previous_stmt->previous_stmt;
- }
- while ((c != (ffestwCase) &s->first_rel) && (casenum == c->casenum));
- fputc (')', dmpout);
- }
-
- fputc ('\n', dmpout);
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
- {
- tree texprlow;
- tree texprhigh;
- tree tlabel;
- int pushok;
- tree duplicate;
-
- ffeste_emit_line_note_ ();
+ ffeste_emit_line_note_ ();
- if (ffestw_select_texpr (block) == error_mark_node)
- return;
+ if (ffestw_select_texpr (block) == error_mark_node)
+ return;
- /* ~~~Someday handle CHARACTER*1, CHARACTER*N */
+ /* ~~~Someday handle CHARACTER*1, CHARACTER*N */
- tlabel = build_decl (LABEL_DECL, NULL_TREE, NULL_TREE);
+ tlabel = build_decl (LABEL_DECL, NULL_TREE, NULL_TREE);
- if (ffestw_select_break (block))
- expand_exit_something ();
- else
- ffestw_set_select_break (block, TRUE);
+ if (ffestw_select_break (block))
+ expand_exit_something ();
+ else
+ ffestw_set_select_break (block, TRUE);
- if ((c == NULL) || (casenum != c->casenum))
+ if ((c == NULL) || (casenum != c->casenum))
+ {
+ if (casenum == 0) /* Intentional CASE DEFAULT. */
+ {
+ pushok = pushcase (NULL_TREE, 0, tlabel, &duplicate);
+ assert (pushok == 0);
+ }
+ }
+ else
+ do
{
- if (casenum == 0) /* Intentional CASE DEFAULT. */
+ texprlow = (c->low == NULL) ? NULL_TREE
+ : ffecom_constantunion (&ffebld_constant_union (c->low), s->type,
+ s->kindtype,
+ ffecom_tree_type[s->type][s->kindtype]);
+ if (c->low != c->high)
{
- pushok = pushcase (NULL_TREE, 0, tlabel, &duplicate);
- assert (pushok == 0);
+ texprhigh = (c->high == NULL) ? NULL_TREE
+ : ffecom_constantunion (&ffebld_constant_union (c->high),
+ s->type, s->kindtype,
+ ffecom_tree_type[s->type][s->kindtype]);
+ pushok = pushcase_range (texprlow, texprhigh, convert,
+ tlabel, &duplicate);
}
+ else
+ pushok = pushcase (texprlow, convert, tlabel, &duplicate);
+ assert (pushok == 0);
+ c = c->next_stmt;
+ /* Unlink prev. */
+ c->previous_stmt->previous_stmt->next_stmt = c;
+ c->previous_stmt = c->previous_stmt->previous_stmt;
}
- else
- do
- {
- texprlow = (c->low == NULL) ? NULL_TREE
- : ffecom_constantunion (&ffebld_constant_union (c->low), s->type,
- s->kindtype, ffecom_tree_type[s->type][s->kindtype]);
- if (c->low != c->high)
- {
- texprhigh = (c->high == NULL) ? NULL_TREE
- : ffecom_constantunion (&ffebld_constant_union (c->high),
- s->type, s->kindtype, ffecom_tree_type[s->type][s->kindtype]);
- pushok = pushcase_range (texprlow, texprhigh, convert,
- tlabel, &duplicate);
- }
- else
- pushok = pushcase (texprlow, convert, tlabel, &duplicate);
- assert (pushok == 0);
- c = c->next_stmt;
- /* Unlink prev. */
- c->previous_stmt->previous_stmt->next_stmt = c;
- c->previous_stmt = c->previous_stmt->previous_stmt;
- }
- while ((c != (ffestwCase) &s->first_rel) && (casenum == c->casenum));
- }
-#else
-#error
-#endif
+ while ((c != (ffestwCase) &s->first_rel) && (casenum == c->casenum));
}
/* END SELECT statement. */
void
ffeste_R811 (ffestw block)
{
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- fputs ("+ END_SELECT\n", dmpout);
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
ffeste_emit_line_note_ ();
/* ~~~Someday handle CHARACTER*1, CHARACTER*N */
expand_end_case (ffestw_select_texpr (block));
ffeste_end_block_ (block);
-#else
-#error
-#endif
}
/* Iterative DO statement. */
{
ffeste_check_simple_ ();
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- if ((ffebld_op (incr) == FFEBLD_opCONTER)
- && (ffebld_constant_is_zero (ffebld_conter (incr))))
- {
- ffebad_start (FFEBAD_DO_STEP_ZERO);
- ffebad_here (0, ffelex_token_where_line (incr_token),
- ffelex_token_where_column (incr_token));
- ffebad_string ("Iterative DO loop");
- ffebad_finish ();
- /* Don't bother replacing it with 1 yet. */
- }
+ ffeste_emit_line_note_ ();
- if (label == NULL)
- fputs ("+ DO_iterative_nonlabeled (", dmpout);
- else
- fprintf (dmpout, "+ DO_iterative_labeled %lu (", ffelab_value (label));
- ffebld_dump (var);
- fputc ('=', dmpout);
- ffebld_dump (start);
- fputc (',', dmpout);
- ffebld_dump (end);
- fputc (',', dmpout);
- ffebld_dump (incr);
- fputs (")\n", dmpout);
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
- {
- ffeste_emit_line_note_ ();
-
- ffeste_begin_iterdo_ (block, NULL, NULL, NULL,
- var,
- start, start_token,
- end, end_token,
- incr, incr_token,
- "Iterative DO loop");
- }
-#else
-#error
-#endif
+ ffeste_begin_iterdo_ (block, NULL, NULL, NULL,
+ var,
+ start, start_token,
+ end, end_token,
+ incr, incr_token,
+ "Iterative DO loop");
}
/* DO WHILE statement. */
void
ffeste_R819B (ffestw block, ffelab label UNUSED, ffebld expr)
{
- ffeste_check_simple_ ();
+ tree result;
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- if (label == NULL)
- fputs ("+ DO_WHILE_nonlabeled (", dmpout);
- else
- fprintf (dmpout, "+ DO_WHILE_labeled %lu (", ffelab_value (label));
- ffebld_dump (expr);
- fputs (")\n", dmpout);
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
- {
- tree result;
+ ffeste_check_simple_ ();
- ffeste_emit_line_note_ ();
+ ffeste_emit_line_note_ ();
- ffeste_start_block_ (block);
+ ffeste_start_block_ (block);
- if (expr)
- {
- struct nesting *loop;
- tree mod;
+ if (expr)
+ {
+ struct nesting *loop;
+ tree mod;
- result = ffecom_make_tempvar ("dowhile", integer_type_node,
- FFETARGET_charactersizeNONE, -1);
- loop = expand_start_loop (1);
+ result = ffecom_make_tempvar ("dowhile", integer_type_node,
+ FFETARGET_charactersizeNONE, -1);
+ loop = expand_start_loop (1);
- ffeste_start_stmt_ ();
+ ffeste_start_stmt_ ();
- ffecom_prepare_expr (expr);
+ ffecom_prepare_expr (expr);
- ffecom_prepare_end ();
+ ffecom_prepare_end ();
- mod = ffecom_modify (void_type_node,
- result,
- ffecom_truth_value (ffecom_expr (expr)));
- expand_expr_stmt (mod);
+ mod = ffecom_modify (void_type_node,
+ result,
+ ffecom_truth_value (ffecom_expr (expr)));
+ expand_expr_stmt (mod);
- ffeste_end_stmt_ ();
+ ffeste_end_stmt_ ();
- ffestw_set_do_hook (block, loop);
- expand_exit_loop_if_false (0, result);
- }
- else
- ffestw_set_do_hook (block, expand_start_loop (1));
+ ffestw_set_do_hook (block, loop);
+ expand_exit_loop_if_false (0, result);
+ }
+ else
+ ffestw_set_do_hook (block, expand_start_loop (1));
- ffestw_set_do_tvar (block, NULL_TREE);
- }
-#else
-#error
-#endif
+ ffestw_set_do_tvar (block, NULL_TREE);
}
/* END DO statement.
{
ffeste_check_simple_ ();
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- fputs ("+ END_DO_sugar\n", dmpout);
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
ffeste_emit_line_note_ ();
emit_nop ();
-#else
-#error
-#endif
}
/* CYCLE statement. */
{
ffeste_check_simple_ ();
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- fprintf (dmpout, "+ CYCLE block #%lu\n", ffestw_blocknum (block));
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
ffeste_emit_line_note_ ();
expand_continue_loop (ffestw_do_hook (block));
-#else
-#error
-#endif
}
/* EXIT statement. */
{
ffeste_check_simple_ ();
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- fprintf (dmpout, "+ EXIT block #%lu\n", ffestw_blocknum (block));
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
ffeste_emit_line_note_ ();
expand_exit_loop (ffestw_do_hook (block));
-#else
-#error
-#endif
}
/* GOTO statement. */
void
ffeste_R836 (ffelab label)
{
- ffeste_check_simple_ ();
+ tree glabel;
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- fprintf (dmpout, "+ GOTO %lu\n", ffelab_value (label));
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
- {
- tree glabel;
+ ffeste_check_simple_ ();
- ffeste_emit_line_note_ ();
+ ffeste_emit_line_note_ ();
- glabel = ffecom_lookup_label (label);
- if ((glabel != NULL_TREE)
- && (TREE_CODE (glabel) != ERROR_MARK))
- {
- expand_goto (glabel);
- TREE_USED (glabel) = 1;
- }
- }
-#else
-#error
-#endif
+ glabel = ffecom_lookup_label (label);
+ if ((glabel != NULL_TREE)
+ && (TREE_CODE (glabel) != ERROR_MARK))
+ {
+ expand_goto (glabel);
+ TREE_USED (glabel) = 1;
+ }
}
/* Computed GOTO statement. */
ffeste_R837 (ffelab *labels, int count, ffebld expr)
{
int i;
+ tree texpr;
+ tree value;
+ tree tlabel;
+ int pushok;
+ tree duplicate;
ffeste_check_simple_ ();
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- fputs ("+ CGOTO (", dmpout);
- for (i = 0; i < count; ++i)
- {
- if (i != 0)
- fputc (',', dmpout);
- fprintf (dmpout, "%" ffelabValue_f "u", ffelab_value (labels[i]));
- }
- fputs ("),", dmpout);
- ffebld_dump (expr);
- fputc ('\n', dmpout);
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
- {
- tree texpr;
- tree value;
- tree tlabel;
- int pushok;
- tree duplicate;
-
- ffeste_emit_line_note_ ();
+ ffeste_emit_line_note_ ();
- ffeste_start_stmt_ ();
+ ffeste_start_stmt_ ();
- ffecom_prepare_expr (expr);
+ ffecom_prepare_expr (expr);
- ffecom_prepare_end ();
+ ffecom_prepare_end ();
- texpr = ffecom_expr (expr);
+ texpr = ffecom_expr (expr);
- expand_start_case (0, texpr, TREE_TYPE (texpr), "computed GOTO statement");
+ expand_start_case (0, texpr, TREE_TYPE (texpr), "computed GOTO statement");
- for (i = 0; i < count; ++i)
- {
- value = build_int_2 (i + 1, 0);
- tlabel = build_decl (LABEL_DECL, NULL_TREE, NULL_TREE);
+ for (i = 0; i < count; ++i)
+ {
+ value = build_int_2 (i + 1, 0);
+ tlabel = build_decl (LABEL_DECL, NULL_TREE, NULL_TREE);
- pushok = pushcase (value, convert, tlabel, &duplicate);
- assert (pushok == 0);
+ pushok = pushcase (value, convert, tlabel, &duplicate);
+ assert (pushok == 0);
- tlabel = ffecom_lookup_label (labels[i]);
- if ((tlabel == NULL_TREE)
- || (TREE_CODE (tlabel) == ERROR_MARK))
- continue;
+ tlabel = ffecom_lookup_label (labels[i]);
+ if ((tlabel == NULL_TREE)
+ || (TREE_CODE (tlabel) == ERROR_MARK))
+ continue;
- expand_goto (tlabel);
- TREE_USED (tlabel) = 1;
- }
- expand_end_case (texpr);
+ expand_goto (tlabel);
+ TREE_USED (tlabel) = 1;
+ }
+ expand_end_case (texpr);
- ffeste_end_stmt_ ();
- }
-#else
-#error
-#endif
+ ffeste_end_stmt_ ();
}
/* ASSIGN statement. */
void
ffeste_R838 (ffelab label, ffebld target)
{
- ffeste_check_simple_ ();
+ tree expr_tree;
+ tree label_tree;
+ tree target_tree;
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- fprintf (dmpout, "+ ASSIGN %lu TO ", ffelab_value (label));
- ffebld_dump (target);
- fputc ('\n', dmpout);
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
- {
- tree expr_tree;
- tree label_tree;
- tree target_tree;
+ ffeste_check_simple_ ();
- ffeste_emit_line_note_ ();
+ ffeste_emit_line_note_ ();
/* No need to call ffeste_start_stmt_(), as the sorts of expressions
seen here should never require use of temporaries. */
- label_tree = ffecom_lookup_label (label);
- if ((label_tree != NULL_TREE)
- && (TREE_CODE (label_tree) != ERROR_MARK))
- {
- label_tree = ffecom_1 (ADDR_EXPR,
- build_pointer_type (void_type_node),
- label_tree);
- TREE_CONSTANT (label_tree) = 1;
-
- target_tree = ffecom_expr_assign_w (target);
- if (GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (target_tree)))
- < GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (label_tree))))
- error ("ASSIGN to variable that is too small");
-
- label_tree = convert (TREE_TYPE (target_tree), label_tree);
-
- expr_tree = ffecom_modify (void_type_node,
- target_tree,
- label_tree);
- expand_expr_stmt (expr_tree);
- }
- }
-#else
-#error
-#endif
+ label_tree = ffecom_lookup_label (label);
+ if ((label_tree != NULL_TREE)
+ && (TREE_CODE (label_tree) != ERROR_MARK))
+ {
+ label_tree = ffecom_1 (ADDR_EXPR,
+ build_pointer_type (void_type_node),
+ label_tree);
+ TREE_CONSTANT (label_tree) = 1;
+
+ target_tree = ffecom_expr_assign_w (target);
+ if (GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (target_tree)))
+ < GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (label_tree))))
+ error ("ASSIGN to variable that is too small");
+
+ label_tree = convert (TREE_TYPE (target_tree), label_tree);
+
+ expr_tree = ffecom_modify (void_type_node,
+ target_tree,
+ label_tree);
+ expand_expr_stmt (expr_tree);
+ }
}
/* Assigned GOTO statement. */
void
ffeste_R839 (ffebld target)
{
- ffeste_check_simple_ ();
+ tree t;
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- fputs ("+ AGOTO ", dmpout);
- ffebld_dump (target);
- fputc ('\n', dmpout);
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
- {
- tree t;
+ ffeste_check_simple_ ();
- ffeste_emit_line_note_ ();
+ ffeste_emit_line_note_ ();
- /* No need to call ffeste_start_stmt_(), as the sorts of expressions
- seen here should never require use of temporaries. */
+ /* No need to call ffeste_start_stmt_(), as the sorts of expressions
+ seen here should never require use of temporaries. */
- t = ffecom_expr_assign (target);
- if (GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (t)))
- < GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node))))
- error ("ASSIGNed GOTO target variable is too small");
+ t = ffecom_expr_assign (target);
+ if (GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (t)))
+ < GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node))))
+ error ("ASSIGNed GOTO target variable is too small");
- expand_computed_goto (convert (TREE_TYPE (null_pointer_node), t));
- }
-#else
-#error
-#endif
+ expand_computed_goto (convert (TREE_TYPE (null_pointer_node), t));
}
/* Arithmetic IF statement. */
void
ffeste_R840 (ffebld expr, ffelab neg, ffelab zero, ffelab pos)
{
+ tree gneg = ffecom_lookup_label (neg);
+ tree gzero = ffecom_lookup_label (zero);
+ tree gpos = ffecom_lookup_label (pos);
+ tree texpr;
+
ffeste_check_simple_ ();
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- fputs ("+ IF_arithmetic (", dmpout);
- ffebld_dump (expr);
- fprintf (dmpout, ") %" ffelabValue_f "u,%" ffelabValue_f "u,%" ffelabValue_f "u\n",
- ffelab_value (neg), ffelab_value (zero), ffelab_value (pos));
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
- {
- tree gneg = ffecom_lookup_label (neg);
- tree gzero = ffecom_lookup_label (zero);
- tree gpos = ffecom_lookup_label (pos);
- tree texpr;
+ ffeste_emit_line_note_ ();
- ffeste_emit_line_note_ ();
+ if ((gneg == NULL_TREE) || (gzero == NULL_TREE) || (gpos == NULL_TREE))
+ return;
+ if ((TREE_CODE (gneg) == ERROR_MARK)
+ || (TREE_CODE (gzero) == ERROR_MARK)
+ || (TREE_CODE (gpos) == ERROR_MARK))
+ return;
- if ((gneg == NULL_TREE) || (gzero == NULL_TREE) || (gpos == NULL_TREE))
- return;
- if ((TREE_CODE (gneg) == ERROR_MARK)
- || (TREE_CODE (gzero) == ERROR_MARK)
- || (TREE_CODE (gpos) == ERROR_MARK))
- return;
+ ffeste_start_stmt_ ();
- ffeste_start_stmt_ ();
+ ffecom_prepare_expr (expr);
- ffecom_prepare_expr (expr);
-
- ffecom_prepare_end ();
+ ffecom_prepare_end ();
- if (neg == zero)
- {
- if (neg == pos)
- expand_goto (gzero);
- else
- {
- /* IF (expr.LE.0) THEN GOTO neg/zero ELSE GOTO pos. */
- texpr = ffecom_expr (expr);
- texpr = ffecom_2 (LE_EXPR, integer_type_node,
- texpr,
- convert (TREE_TYPE (texpr),
- integer_zero_node));
- expand_start_cond (ffecom_truth_value (texpr), 0);
- expand_goto (gzero);
- expand_start_else ();
- expand_goto (gpos);
- expand_end_cond ();
- }
- }
- else if (neg == pos)
- {
- /* IF (expr.NE.0) THEN GOTO neg/pos ELSE GOTO zero. */
- texpr = ffecom_expr (expr);
- texpr = ffecom_2 (NE_EXPR, integer_type_node,
- texpr,
- convert (TREE_TYPE (texpr),
- integer_zero_node));
- expand_start_cond (ffecom_truth_value (texpr), 0);
- expand_goto (gneg);
- expand_start_else ();
- expand_goto (gzero);
- expand_end_cond ();
- }
- else if (zero == pos)
- {
- /* IF (expr.GE.0) THEN GOTO zero/pos ELSE GOTO neg. */
- texpr = ffecom_expr (expr);
- texpr = ffecom_2 (GE_EXPR, integer_type_node,
- texpr,
- convert (TREE_TYPE (texpr),
- integer_zero_node));
- expand_start_cond (ffecom_truth_value (texpr), 0);
- expand_goto (gzero);
- expand_start_else ();
- expand_goto (gneg);
- expand_end_cond ();
- }
- else
- {
- /* Use a SAVE_EXPR in combo with:
- IF (expr.LT.0) THEN GOTO neg
- ELSEIF (expr.GT.0) THEN GOTO pos
- ELSE GOTO zero. */
- tree expr_saved = ffecom_save_tree (ffecom_expr (expr));
-
- texpr = ffecom_2 (LT_EXPR, integer_type_node,
- expr_saved,
- convert (TREE_TYPE (expr_saved),
- integer_zero_node));
- expand_start_cond (ffecom_truth_value (texpr), 0);
- expand_goto (gneg);
- texpr = ffecom_2 (GT_EXPR, integer_type_node,
- expr_saved,
- convert (TREE_TYPE (expr_saved),
- integer_zero_node));
- expand_start_elseif (ffecom_truth_value (texpr));
- expand_goto (gpos);
- expand_start_else ();
+ if (neg == zero)
+ {
+ if (neg == pos)
expand_goto (gzero);
- expand_end_cond ();
- }
+ else
+ {
+ /* IF (expr.LE.0) THEN GOTO neg/zero ELSE GOTO pos. */
+ texpr = ffecom_expr (expr);
+ texpr = ffecom_2 (LE_EXPR, integer_type_node,
+ texpr,
+ convert (TREE_TYPE (texpr),
+ integer_zero_node));
+ expand_start_cond (ffecom_truth_value (texpr), 0);
+ expand_goto (gzero);
+ expand_start_else ();
+ expand_goto (gpos);
+ expand_end_cond ();
+ }
+ }
+ else if (neg == pos)
+ {
+ /* IF (expr.NE.0) THEN GOTO neg/pos ELSE GOTO zero. */
+ texpr = ffecom_expr (expr);
+ texpr = ffecom_2 (NE_EXPR, integer_type_node,
+ texpr,
+ convert (TREE_TYPE (texpr),
+ integer_zero_node));
+ expand_start_cond (ffecom_truth_value (texpr), 0);
+ expand_goto (gneg);
+ expand_start_else ();
+ expand_goto (gzero);
+ expand_end_cond ();
+ }
+ else if (zero == pos)
+ {
+ /* IF (expr.GE.0) THEN GOTO zero/pos ELSE GOTO neg. */
+ texpr = ffecom_expr (expr);
+ texpr = ffecom_2 (GE_EXPR, integer_type_node,
+ texpr,
+ convert (TREE_TYPE (texpr),
+ integer_zero_node));
+ expand_start_cond (ffecom_truth_value (texpr), 0);
+ expand_goto (gzero);
+ expand_start_else ();
+ expand_goto (gneg);
+ expand_end_cond ();
+ }
+ else
+ {
+ /* Use a SAVE_EXPR in combo with:
+ IF (expr.LT.0) THEN GOTO neg
+ ELSEIF (expr.GT.0) THEN GOTO pos
+ ELSE GOTO zero. */
+ tree expr_saved = ffecom_save_tree (ffecom_expr (expr));
+
+ texpr = ffecom_2 (LT_EXPR, integer_type_node,
+ expr_saved,
+ convert (TREE_TYPE (expr_saved),
+ integer_zero_node));
+ expand_start_cond (ffecom_truth_value (texpr), 0);
+ expand_goto (gneg);
+ texpr = ffecom_2 (GT_EXPR, integer_type_node,
+ expr_saved,
+ convert (TREE_TYPE (expr_saved),
+ integer_zero_node));
+ expand_start_elseif (ffecom_truth_value (texpr));
+ expand_goto (gpos);
+ expand_start_else ();
+ expand_goto (gzero);
+ expand_end_cond ();
+ }
- ffeste_end_stmt_ ();
- }
-#else
-#error
-#endif
+ ffeste_end_stmt_ ();
}
/* CONTINUE statement. */
{
ffeste_check_simple_ ();
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- fputs ("+ CONTINUE\n", dmpout);
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
ffeste_emit_line_note_ ();
emit_nop ();
-#else
-#error
-#endif
}
/* STOP statement. */
void
ffeste_R842 (ffebld expr)
{
+ tree callit;
+ ffelexToken msg;
+
ffeste_check_simple_ ();
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- if (expr == NULL)
+ ffeste_emit_line_note_ ();
+
+ if ((expr == NULL)
+ || (ffeinfo_basictype (ffebld_info (expr))
+ == FFEINFO_basictypeANY))
{
- fputs ("+ STOP\n", dmpout);
+ msg = ffelex_token_new_character ("",
+ ffelex_token_where_line (ffesta_tokens[0]),
+ ffelex_token_where_column (ffesta_tokens[0]));
+ expr = ffebld_new_conter (ffebld_constant_new_characterdefault
+ (msg));
+ ffelex_token_kill (msg);
+ ffebld_set_info (expr, ffeinfo_new (FFEINFO_basictypeCHARACTER,
+ FFEINFO_kindtypeCHARACTERDEFAULT,
+ 0, FFEINFO_kindENTITY,
+ FFEINFO_whereCONSTANT, 0));
+ }
+ else if (ffeinfo_basictype (ffebld_info (expr))
+ == FFEINFO_basictypeINTEGER)
+ {
+ char num[50];
+
+ assert (ffebld_op (expr) == FFEBLD_opCONTER);
+ assert (ffeinfo_kindtype (ffebld_info (expr))
+ == FFEINFO_kindtypeINTEGERDEFAULT);
+ sprintf (num, "%" ffetargetIntegerDefault_f "d",
+ ffebld_constant_integer1 (ffebld_conter (expr)));
+ msg = ffelex_token_new_character (num,
+ ffelex_token_where_line (ffesta_tokens[0]),
+ ffelex_token_where_column (ffesta_tokens[0]));
+ expr = ffebld_new_conter (ffebld_constant_new_characterdefault (msg));
+ ffelex_token_kill (msg);
+ ffebld_set_info (expr, ffeinfo_new (FFEINFO_basictypeCHARACTER,
+ FFEINFO_kindtypeCHARACTERDEFAULT,
+ 0, FFEINFO_kindENTITY,
+ FFEINFO_whereCONSTANT, 0));
}
else
{
- fputs ("+ STOP_coded ", dmpout);
- ffebld_dump (expr);
- fputc ('\n', dmpout);
+ assert (ffeinfo_basictype (ffebld_info (expr))
+ == FFEINFO_basictypeCHARACTER);
+ assert (ffebld_op (expr) == FFEBLD_opCONTER);
+ assert (ffeinfo_kindtype (ffebld_info (expr))
+ == FFEINFO_kindtypeCHARACTERDEFAULT);
}
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
- {
- tree callit;
- ffelexToken msg;
- ffeste_emit_line_note_ ();
+ /* No need to call ffeste_start_stmt_(), as the sorts of expressions
+ seen here should never require use of temporaries. */
- if ((expr == NULL)
- || (ffeinfo_basictype (ffebld_info (expr))
- == FFEINFO_basictypeANY))
- {
- msg = ffelex_token_new_character ("", ffelex_token_where_line
- (ffesta_tokens[0]), ffelex_token_where_column
- (ffesta_tokens[0]));
- expr = ffebld_new_conter (ffebld_constant_new_characterdefault
- (msg));
- ffelex_token_kill (msg);
- ffebld_set_info (expr, ffeinfo_new (FFEINFO_basictypeCHARACTER,
- FFEINFO_kindtypeCHARACTERDEFAULT, 0, FFEINFO_kindENTITY,
- FFEINFO_whereCONSTANT, 0));
- }
- else if (ffeinfo_basictype (ffebld_info (expr))
- == FFEINFO_basictypeINTEGER)
- {
- char num[50];
-
- assert (ffebld_op (expr) == FFEBLD_opCONTER);
- assert (ffeinfo_kindtype (ffebld_info (expr))
- == FFEINFO_kindtypeINTEGERDEFAULT);
- sprintf (num, "%" ffetargetIntegerDefault_f "d",
- ffebld_constant_integer1 (ffebld_conter (expr)));
- msg = ffelex_token_new_character (num, ffelex_token_where_line
- (ffesta_tokens[0]), ffelex_token_where_column
- (ffesta_tokens[0]));
- expr = ffebld_new_conter (ffebld_constant_new_characterdefault
- (msg));
- ffelex_token_kill (msg);
- ffebld_set_info (expr, ffeinfo_new (FFEINFO_basictypeCHARACTER,
- FFEINFO_kindtypeCHARACTERDEFAULT, 0, FFEINFO_kindENTITY,
- FFEINFO_whereCONSTANT, 0));
- }
- else
- {
- assert (ffeinfo_basictype (ffebld_info (expr))
- == FFEINFO_basictypeCHARACTER);
- assert (ffebld_op (expr) == FFEBLD_opCONTER);
- assert (ffeinfo_kindtype (ffebld_info (expr))
- == FFEINFO_kindtypeCHARACTERDEFAULT);
- }
+ callit = ffecom_call_gfrt (FFECOM_gfrtSTOP,
+ ffecom_list_ptr_to_expr (ffebld_new_item (expr, NULL)),
+ NULL_TREE);
+ TREE_SIDE_EFFECTS (callit) = 1;
- /* No need to call ffeste_start_stmt_(), as the sorts of expressions
- seen here should never require use of temporaries. */
-
- callit = ffecom_call_gfrt (FFECOM_gfrtSTOP,
- ffecom_list_ptr_to_expr (ffebld_new_item (expr, NULL)),
- NULL_TREE);
- TREE_SIDE_EFFECTS (callit) = 1;
-
- expand_expr_stmt (callit);
- }
-#else
-#error
-#endif
+ expand_expr_stmt (callit);
}
/* PAUSE statement. */
void
ffeste_R843 (ffebld expr)
{
+ tree callit;
+ ffelexToken msg;
+
ffeste_check_simple_ ();
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- if (expr == NULL)
+ ffeste_emit_line_note_ ();
+
+ if ((expr == NULL)
+ || (ffeinfo_basictype (ffebld_info (expr))
+ == FFEINFO_basictypeANY))
{
- fputs ("+ PAUSE\n", dmpout);
+ msg = ffelex_token_new_character ("",
+ ffelex_token_where_line (ffesta_tokens[0]),
+ ffelex_token_where_column (ffesta_tokens[0]));
+ expr = ffebld_new_conter (ffebld_constant_new_characterdefault (msg));
+ ffelex_token_kill (msg);
+ ffebld_set_info (expr, ffeinfo_new (FFEINFO_basictypeCHARACTER,
+ FFEINFO_kindtypeCHARACTERDEFAULT,
+ 0, FFEINFO_kindENTITY,
+ FFEINFO_whereCONSTANT, 0));
+ }
+ else if (ffeinfo_basictype (ffebld_info (expr)) == FFEINFO_basictypeINTEGER)
+ {
+ char num[50];
+
+ assert (ffebld_op (expr) == FFEBLD_opCONTER);
+ assert (ffeinfo_kindtype (ffebld_info (expr))
+ == FFEINFO_kindtypeINTEGERDEFAULT);
+ sprintf (num, "%" ffetargetIntegerDefault_f "d",
+ ffebld_constant_integer1 (ffebld_conter (expr)));
+ msg = ffelex_token_new_character (num, ffelex_token_where_line (ffesta_tokens[0]),
+ ffelex_token_where_column (ffesta_tokens[0]));
+ expr = ffebld_new_conter (ffebld_constant_new_characterdefault (msg));
+ ffelex_token_kill (msg);
+ ffebld_set_info (expr, ffeinfo_new (FFEINFO_basictypeCHARACTER,
+ FFEINFO_kindtypeCHARACTERDEFAULT,
+ 0, FFEINFO_kindENTITY,
+ FFEINFO_whereCONSTANT, 0));
}
else
{
- fputs ("+ PAUSE_coded ", dmpout);
- ffebld_dump (expr);
- fputc ('\n', dmpout);
+ assert (ffeinfo_basictype (ffebld_info (expr))
+ == FFEINFO_basictypeCHARACTER);
+ assert (ffebld_op (expr) == FFEBLD_opCONTER);
+ assert (ffeinfo_kindtype (ffebld_info (expr))
+ == FFEINFO_kindtypeCHARACTERDEFAULT);
}
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
- {
- tree callit;
- ffelexToken msg;
-
- ffeste_emit_line_note_ ();
- if ((expr == NULL)
- || (ffeinfo_basictype (ffebld_info (expr))
- == FFEINFO_basictypeANY))
- {
- msg = ffelex_token_new_character ("", ffelex_token_where_line
- (ffesta_tokens[0]), ffelex_token_where_column
- (ffesta_tokens[0]));
- expr = ffebld_new_conter (ffebld_constant_new_characterdefault
- (msg));
- ffelex_token_kill (msg);
- ffebld_set_info (expr, ffeinfo_new (FFEINFO_basictypeCHARACTER,
- FFEINFO_kindtypeCHARACTERDEFAULT, 0, FFEINFO_kindENTITY,
- FFEINFO_whereCONSTANT, 0));
- }
- else if (ffeinfo_basictype (ffebld_info (expr))
- == FFEINFO_basictypeINTEGER)
- {
- char num[50];
-
- assert (ffebld_op (expr) == FFEBLD_opCONTER);
- assert (ffeinfo_kindtype (ffebld_info (expr))
- == FFEINFO_kindtypeINTEGERDEFAULT);
- sprintf (num, "%" ffetargetIntegerDefault_f "d",
- ffebld_constant_integer1 (ffebld_conter (expr)));
- msg = ffelex_token_new_character (num, ffelex_token_where_line
- (ffesta_tokens[0]), ffelex_token_where_column
- (ffesta_tokens[0]));
- expr = ffebld_new_conter (ffebld_constant_new_characterdefault
- (msg));
- ffelex_token_kill (msg);
- ffebld_set_info (expr, ffeinfo_new (FFEINFO_basictypeCHARACTER,
- FFEINFO_kindtypeCHARACTERDEFAULT, 0, FFEINFO_kindENTITY,
- FFEINFO_whereCONSTANT, 0));
- }
- else
- {
- assert (ffeinfo_basictype (ffebld_info (expr))
- == FFEINFO_basictypeCHARACTER);
- assert (ffebld_op (expr) == FFEBLD_opCONTER);
- assert (ffeinfo_kindtype (ffebld_info (expr))
- == FFEINFO_kindtypeCHARACTERDEFAULT);
- }
-
- /* No need to call ffeste_start_stmt_(), as the sorts of expressions
- seen here should never require use of temporaries. */
+ /* No need to call ffeste_start_stmt_(), as the sorts of expressions
+ seen here should never require use of temporaries. */
- callit = ffecom_call_gfrt (FFECOM_gfrtPAUSE,
- ffecom_list_ptr_to_expr (ffebld_new_item (expr, NULL)),
- NULL_TREE);
- TREE_SIDE_EFFECTS (callit) = 1;
+ callit = ffecom_call_gfrt (FFECOM_gfrtPAUSE,
+ ffecom_list_ptr_to_expr (ffebld_new_item (expr, NULL)),
+ NULL_TREE);
+ TREE_SIDE_EFFECTS (callit) = 1;
- expand_expr_stmt (callit);
- }
-#if 0 /* Old approach for phantom g77 run-time
- library. */
- {
- tree callit;
-
- ffeste_emit_line_note_ ();
-
- if (expr == NULL)
- callit = ffecom_call_gfrt (FFECOM_gfrtPAUSENIL, NULL_TREE, NULL_TREE);
- else if (ffeinfo_basictype (ffebld_info (expr))
- == FFEINFO_basictypeINTEGER)
- callit = ffecom_call_gfrt (FFECOM_gfrtPAUSEINT,
- ffecom_list_ptr_to_expr (ffebld_new_item (expr, NULL)),
- NULL_TREE);
- else if (ffeinfo_basictype (ffebld_info (expr))
- == FFEINFO_basictypeCHARACTER)
- callit = ffecom_call_gfrt (FFECOM_gfrtPAUSECHAR,
- ffecom_list_ptr_to_expr (ffebld_new_item (expr, NULL)),
- NULL_TREE);
- else
- abort ();
- TREE_SIDE_EFFECTS (callit) = 1;
-
- expand_expr_stmt (callit);
- }
-#endif
-#else
-#error
-#endif
+ expand_expr_stmt (callit);
}
/* OPEN statement. */
void
ffeste_R904 (ffestpOpenStmt *info)
{
- ffeste_check_simple_ ();
+ tree args;
+ bool iostat;
+ bool errl;
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- fputs ("+ OPEN (", dmpout);
- ffeste_subr_file_ ("UNIT", &info->open_spec[FFESTP_openixUNIT]);
- ffeste_subr_file_ ("ACCESS", &info->open_spec[FFESTP_openixACCESS]);
- ffeste_subr_file_ ("ACTION", &info->open_spec[FFESTP_openixACTION]);
- ffeste_subr_file_ ("ASSOCIATEVARIABLE", &info->open_spec[FFESTP_openixASSOCIATEVARIABLE]);
- ffeste_subr_file_ ("BLANK", &info->open_spec[FFESTP_openixBLANK]);
- ffeste_subr_file_ ("BLOCKSIZE", &info->open_spec[FFESTP_openixBLOCKSIZE]);
- ffeste_subr_file_ ("BUFFERCOUNT", &info->open_spec[FFESTP_openixBUFFERCOUNT]);
- ffeste_subr_file_ ("CARRIAGECONTROL", &info->open_spec[FFESTP_openixCARRIAGECONTROL]);
- ffeste_subr_file_ ("DEFAULTFILE", &info->open_spec[FFESTP_openixDEFAULTFILE]);
- ffeste_subr_file_ ("DELIM", &info->open_spec[FFESTP_openixDELIM]);
- ffeste_subr_file_ ("DISPOSE", &info->open_spec[FFESTP_openixDISPOSE]);
- ffeste_subr_file_ ("ERR", &info->open_spec[FFESTP_openixERR]);
- ffeste_subr_file_ ("EXTENDSIZE", &info->open_spec[FFESTP_openixEXTENDSIZE]);
- ffeste_subr_file_ ("FILE", &info->open_spec[FFESTP_openixFILE]);
- ffeste_subr_file_ ("FORM", &info->open_spec[FFESTP_openixFORM]);
- ffeste_subr_file_ ("INITIALSIZE", &info->open_spec[FFESTP_openixINITIALSIZE]);
- ffeste_subr_file_ ("IOSTAT", &info->open_spec[FFESTP_openixIOSTAT]);
- ffeste_subr_file_ ("KEY", &info->open_spec[FFESTP_openixKEY]);
- ffeste_subr_file_ ("MAXREC", &info->open_spec[FFESTP_openixMAXREC]);
- ffeste_subr_file_ ("NOSPANBLOCKS", &info->open_spec[FFESTP_openixNOSPANBLOCKS]);
- ffeste_subr_file_ ("ORGANIZATION", &info->open_spec[FFESTP_openixORGANIZATION]);
- ffeste_subr_file_ ("PAD", &info->open_spec[FFESTP_openixPAD]);
- ffeste_subr_file_ ("POSITION", &info->open_spec[FFESTP_openixPOSITION]);
- ffeste_subr_file_ ("READONLY", &info->open_spec[FFESTP_openixREADONLY]);
- ffeste_subr_file_ ("RECL", &info->open_spec[FFESTP_openixRECL]);
- ffeste_subr_file_ ("RECORDTYPE", &info->open_spec[FFESTP_openixRECORDTYPE]);
- ffeste_subr_file_ ("SHARED", &info->open_spec[FFESTP_openixSHARED]);
- ffeste_subr_file_ ("STATUS", &info->open_spec[FFESTP_openixSTATUS]);
- ffeste_subr_file_ ("USEROPEN", &info->open_spec[FFESTP_openixUSEROPEN]);
- fputs (")\n", dmpout);
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
- {
- tree args;
- bool iostat;
- bool errl;
+ ffeste_check_simple_ ();
- ffeste_emit_line_note_ ();
+ ffeste_emit_line_note_ ();
#define specified(something) (info->open_spec[something].kw_or_val_present)
- iostat = specified (FFESTP_openixIOSTAT);
- errl = specified (FFESTP_openixERR);
+ iostat = specified (FFESTP_openixIOSTAT);
+ errl = specified (FFESTP_openixERR);
#undef specified
- ffeste_start_stmt_ ();
+ ffeste_start_stmt_ ();
- if (errl)
- {
- ffeste_io_err_
- = ffeste_io_abort_
- = ffecom_lookup_label
- (info->open_spec[FFESTP_openixERR].u.label);
- ffeste_io_abort_is_temp_ = FALSE;
- }
- else
- {
- ffeste_io_err_ = NULL_TREE;
+ if (errl)
+ {
+ ffeste_io_err_
+ = ffeste_io_abort_
+ = ffecom_lookup_label
+ (info->open_spec[FFESTP_openixERR].u.label);
+ ffeste_io_abort_is_temp_ = FALSE;
+ }
+ else
+ {
+ ffeste_io_err_ = NULL_TREE;
- if ((ffeste_io_abort_is_temp_ = iostat))
- ffeste_io_abort_ = ffecom_temp_label ();
- else
- ffeste_io_abort_ = NULL_TREE;
- }
+ if ((ffeste_io_abort_is_temp_ = iostat))
+ ffeste_io_abort_ = ffecom_temp_label ();
+ else
+ ffeste_io_abort_ = NULL_TREE;
+ }
- if (iostat)
- {
- /* Have IOSTAT= specification. */
+ if (iostat)
+ {
+ /* Have IOSTAT= specification. */
- ffeste_io_iostat_is_temp_ = FALSE;
- ffeste_io_iostat_ = ffecom_expr
- (info->open_spec[FFESTP_openixIOSTAT].u.expr);
- }
- else if (ffeste_io_abort_ != NULL_TREE)
- {
- /* Have no IOSTAT= but have ERR=. */
+ ffeste_io_iostat_is_temp_ = FALSE;
+ ffeste_io_iostat_ = ffecom_expr
+ (info->open_spec[FFESTP_openixIOSTAT].u.expr);
+ }
+ else if (ffeste_io_abort_ != NULL_TREE)
+ {
+ /* Have no IOSTAT= but have ERR=. */
- ffeste_io_iostat_is_temp_ = TRUE;
- ffeste_io_iostat_
- = ffecom_make_tempvar ("open", ffecom_integer_type_node,
- FFETARGET_charactersizeNONE, -1);
- }
- else
- {
- /* No IOSTAT= or ERR= specification. */
+ ffeste_io_iostat_is_temp_ = TRUE;
+ ffeste_io_iostat_
+ = ffecom_make_tempvar ("open", ffecom_integer_type_node,
+ FFETARGET_charactersizeNONE, -1);
+ }
+ else
+ {
+ /* No IOSTAT= or ERR= specification. */
- ffeste_io_iostat_is_temp_ = FALSE;
- ffeste_io_iostat_ = NULL_TREE;
- }
+ ffeste_io_iostat_is_temp_ = FALSE;
+ ffeste_io_iostat_ = NULL_TREE;
+ }
- /* Now prescan, then convert, all the arguments. */
+ /* Now prescan, then convert, all the arguments. */
- args = ffeste_io_olist_ (errl || iostat,
- info->open_spec[FFESTP_openixUNIT].u.expr,
- &info->open_spec[FFESTP_openixFILE],
- &info->open_spec[FFESTP_openixSTATUS],
- &info->open_spec[FFESTP_openixACCESS],
- &info->open_spec[FFESTP_openixFORM],
- &info->open_spec[FFESTP_openixRECL],
- &info->open_spec[FFESTP_openixBLANK]);
+ args = ffeste_io_olist_ (errl || iostat,
+ info->open_spec[FFESTP_openixUNIT].u.expr,
+ &info->open_spec[FFESTP_openixFILE],
+ &info->open_spec[FFESTP_openixSTATUS],
+ &info->open_spec[FFESTP_openixACCESS],
+ &info->open_spec[FFESTP_openixFORM],
+ &info->open_spec[FFESTP_openixRECL],
+ &info->open_spec[FFESTP_openixBLANK]);
- /* Don't generate "if (iostat != 0) goto label;" if label is temp abort
+ /* Don't generate "if (iostat != 0) goto label;" if label is temp abort
label, since we're gonna fall through to there anyway. */
- ffeste_io_call_ (ffecom_call_gfrt (FFECOM_gfrtFOPEN, args, NULL_TREE),
- ! ffeste_io_abort_is_temp_);
+ ffeste_io_call_ (ffecom_call_gfrt (FFECOM_gfrtFOPEN, args, NULL_TREE),
+ ! ffeste_io_abort_is_temp_);
- /* If we've got a temp label, generate its code here. */
+ /* If we've got a temp label, generate its code here. */
- if (ffeste_io_abort_is_temp_)
- {
- DECL_INITIAL (ffeste_io_abort_) = error_mark_node;
- emit_nop ();
- expand_label (ffeste_io_abort_);
+ if (ffeste_io_abort_is_temp_)
+ {
+ DECL_INITIAL (ffeste_io_abort_) = error_mark_node;
+ emit_nop ();
+ expand_label (ffeste_io_abort_);
- assert (ffeste_io_err_ == NULL_TREE);
- }
+ assert (ffeste_io_err_ == NULL_TREE);
+ }
- ffeste_end_stmt_ ();
- }
-#else
-#error
-#endif
+ ffeste_end_stmt_ ();
}
/* CLOSE statement. */
void
ffeste_R907 (ffestpCloseStmt *info)
{
- ffeste_check_simple_ ();
+ tree args;
+ bool iostat;
+ bool errl;
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- fputs ("+ CLOSE (", dmpout);
- ffeste_subr_file_ ("UNIT", &info->close_spec[FFESTP_closeixUNIT]);
- ffeste_subr_file_ ("ERR", &info->close_spec[FFESTP_closeixERR]);
- ffeste_subr_file_ ("IOSTAT", &info->close_spec[FFESTP_closeixIOSTAT]);
- ffeste_subr_file_ ("STATUS", &info->close_spec[FFESTP_closeixSTATUS]);
- fputs (")\n", dmpout);
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
- {
- tree args;
- bool iostat;
- bool errl;
+ ffeste_check_simple_ ();
- ffeste_emit_line_note_ ();
+ ffeste_emit_line_note_ ();
#define specified(something) (info->close_spec[something].kw_or_val_present)
- iostat = specified (FFESTP_closeixIOSTAT);
- errl = specified (FFESTP_closeixERR);
+ iostat = specified (FFESTP_closeixIOSTAT);
+ errl = specified (FFESTP_closeixERR);
#undef specified
- ffeste_start_stmt_ ();
+ ffeste_start_stmt_ ();
- if (errl)
- {
- ffeste_io_err_
- = ffeste_io_abort_
- = ffecom_lookup_label
- (info->close_spec[FFESTP_closeixERR].u.label);
- ffeste_io_abort_is_temp_ = FALSE;
- }
- else
- {
- ffeste_io_err_ = NULL_TREE;
+ if (errl)
+ {
+ ffeste_io_err_
+ = ffeste_io_abort_
+ = ffecom_lookup_label
+ (info->close_spec[FFESTP_closeixERR].u.label);
+ ffeste_io_abort_is_temp_ = FALSE;
+ }
+ else
+ {
+ ffeste_io_err_ = NULL_TREE;
- if ((ffeste_io_abort_is_temp_ = iostat))
- ffeste_io_abort_ = ffecom_temp_label ();
- else
- ffeste_io_abort_ = NULL_TREE;
- }
+ if ((ffeste_io_abort_is_temp_ = iostat))
+ ffeste_io_abort_ = ffecom_temp_label ();
+ else
+ ffeste_io_abort_ = NULL_TREE;
+ }
- if (iostat)
- {
- /* Have IOSTAT= specification. */
+ if (iostat)
+ {
+ /* Have IOSTAT= specification. */
- ffeste_io_iostat_is_temp_ = FALSE;
- ffeste_io_iostat_ = ffecom_expr
- (info->close_spec[FFESTP_closeixIOSTAT].u.expr);
- }
- else if (ffeste_io_abort_ != NULL_TREE)
- {
- /* Have no IOSTAT= but have ERR=. */
+ ffeste_io_iostat_is_temp_ = FALSE;
+ ffeste_io_iostat_ = ffecom_expr
+ (info->close_spec[FFESTP_closeixIOSTAT].u.expr);
+ }
+ else if (ffeste_io_abort_ != NULL_TREE)
+ {
+ /* Have no IOSTAT= but have ERR=. */
- ffeste_io_iostat_is_temp_ = TRUE;
- ffeste_io_iostat_
- = ffecom_make_tempvar ("close", ffecom_integer_type_node,
- FFETARGET_charactersizeNONE, -1);
- }
- else
- {
- /* No IOSTAT= or ERR= specification. */
+ ffeste_io_iostat_is_temp_ = TRUE;
+ ffeste_io_iostat_
+ = ffecom_make_tempvar ("close", ffecom_integer_type_node,
+ FFETARGET_charactersizeNONE, -1);
+ }
+ else
+ {
+ /* No IOSTAT= or ERR= specification. */
- ffeste_io_iostat_is_temp_ = FALSE;
- ffeste_io_iostat_ = NULL_TREE;
- }
+ ffeste_io_iostat_is_temp_ = FALSE;
+ ffeste_io_iostat_ = NULL_TREE;
+ }
- /* Now prescan, then convert, all the arguments. */
+ /* Now prescan, then convert, all the arguments. */
- args = ffeste_io_cllist_ (errl || iostat,
- info->close_spec[FFESTP_closeixUNIT].u.expr,
- &info->close_spec[FFESTP_closeixSTATUS]);
+ args = ffeste_io_cllist_ (errl || iostat,
+ info->close_spec[FFESTP_closeixUNIT].u.expr,
+ &info->close_spec[FFESTP_closeixSTATUS]);
- /* Don't generate "if (iostat != 0) goto label;" if label is temp abort
+ /* Don't generate "if (iostat != 0) goto label;" if label is temp abort
label, since we're gonna fall through to there anyway. */
- ffeste_io_call_ (ffecom_call_gfrt (FFECOM_gfrtFCLOS, args, NULL_TREE),
- ! ffeste_io_abort_is_temp_);
+ ffeste_io_call_ (ffecom_call_gfrt (FFECOM_gfrtFCLOS, args, NULL_TREE),
+ ! ffeste_io_abort_is_temp_);
- /* If we've got a temp label, generate its code here. */
+ /* If we've got a temp label, generate its code here. */
- if (ffeste_io_abort_is_temp_)
- {
- DECL_INITIAL (ffeste_io_abort_) = error_mark_node;
- emit_nop ();
- expand_label (ffeste_io_abort_);
+ if (ffeste_io_abort_is_temp_)
+ {
+ DECL_INITIAL (ffeste_io_abort_) = error_mark_node;
+ emit_nop ();
+ expand_label (ffeste_io_abort_);
- assert (ffeste_io_err_ == NULL_TREE);
- }
+ assert (ffeste_io_err_ == NULL_TREE);
+ }
- ffeste_end_stmt_ ();
- }
-#else
-#error
-#endif
+ ffeste_end_stmt_ ();
}
/* READ(...) statement -- start. */
ffestvUnit unit, ffestvFormat format, bool rec,
bool key UNUSED)
{
+ ffecomGfrt start;
+ ffecomGfrt end;
+ tree cilist;
+ bool iostat;
+ bool errl;
+ bool endl;
+
ffeste_check_start_ ();
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
+ ffeste_emit_line_note_ ();
+
+ /* First determine the start, per-item, and end run-time functions to
+ call. The per-item function is picked by choosing an ffeste function
+ to call to handle a given item; it knows how to generate a call to the
+ appropriate run-time function, and is called an "I/O driver". */
+
switch (format)
{
- case FFESTV_formatNONE:
+ case FFESTV_formatNONE: /* no FMT= */
+ ffeste_io_driver_ = ffeste_io_douio_;
if (rec)
- fputs ("+ READ_ufdac", dmpout);
- else if (key)
- fputs ("+ READ_ufidx", dmpout);
+ start = FFECOM_gfrtSRDUE, end = FFECOM_gfrtERDUE;
else
- fputs ("+ READ_ufseq", dmpout);
+ start = FFECOM_gfrtSRSUE, end = FFECOM_gfrtERSUE;
break;
- case FFESTV_formatLABEL:
- case FFESTV_formatCHAREXPR:
- case FFESTV_formatINTEXPR:
+ case FFESTV_formatLABEL: /* FMT=10 */
+ case FFESTV_formatCHAREXPR: /* FMT='(I10)' */
+ case FFESTV_formatINTEXPR: /* FMT=I [after ASSIGN 10 TO I] */
+ ffeste_io_driver_ = ffeste_io_dofio_;
if (rec)
- fputs ("+ READ_fmdac", dmpout);
- else if (key)
- fputs ("+ READ_fmidx", dmpout);
+ start = FFECOM_gfrtSRDFE, end = FFECOM_gfrtERDFE;
else if (unit == FFESTV_unitCHAREXPR)
- fputs ("+ READ_fmint", dmpout);
+ start = FFECOM_gfrtSRSFI, end = FFECOM_gfrtERSFI;
else
- fputs ("+ READ_fmseq", dmpout);
+ start = FFECOM_gfrtSRSFE, end = FFECOM_gfrtERSFE;
break;
- case FFESTV_formatASTERISK:
+ case FFESTV_formatASTERISK: /* FMT=* */
+ ffeste_io_driver_ = ffeste_io_dolio_;
if (unit == FFESTV_unitCHAREXPR)
- fputs ("+ READ_lsint", dmpout);
+ start = FFECOM_gfrtSRSLI, end = FFECOM_gfrtERSLI;
else
- fputs ("+ READ_lsseq", dmpout);
+ start = FFECOM_gfrtSRSLE, end = FFECOM_gfrtERSLE;
break;
- case FFESTV_formatNAMELIST:
- fputs ("+ READ_nlseq", dmpout);
+ case FFESTV_formatNAMELIST: /* FMT=FOO or NML=FOO [NAMELIST
+ /FOO/] */
+ ffeste_io_driver_ = NULL; /* No start or driver function. */
+ start = FFECOM_gfrtSRSNE, end = FFECOM_gfrt;
break;
default:
- assert ("Unexpected kind of format item in R909 READ" == NULL);
- }
-
- if (only_format)
- {
- fputc (' ', dmpout);
- ffeste_subr_file_ ("FORMAT", &info->read_spec[FFESTP_readixFORMAT]);
- fputc (' ', dmpout);
-
- return;
+ assert ("Weird stuff" == NULL);
+ start = FFECOM_gfrt, end = FFECOM_gfrt;
+ break;
}
-
- fputs (" (", dmpout);
- ffeste_subr_file_ ("UNIT", &info->read_spec[FFESTP_readixUNIT]);
- ffeste_subr_file_ ("FORMAT", &info->read_spec[FFESTP_readixFORMAT]);
- ffeste_subr_file_ ("ADVANCE", &info->read_spec[FFESTP_readixADVANCE]);
- ffeste_subr_file_ ("EOR", &info->read_spec[FFESTP_readixEOR]);
- ffeste_subr_file_ ("ERR", &info->read_spec[FFESTP_readixERR]);
- ffeste_subr_file_ ("END", &info->read_spec[FFESTP_readixEND]);
- ffeste_subr_file_ ("IOSTAT", &info->read_spec[FFESTP_readixIOSTAT]);
- ffeste_subr_file_ ("KEYEQ", &info->read_spec[FFESTP_readixKEYEQ]);
- ffeste_subr_file_ ("KEYGE", &info->read_spec[FFESTP_readixKEYGE]);
- ffeste_subr_file_ ("KEYGT", &info->read_spec[FFESTP_readixKEYGT]);
- ffeste_subr_file_ ("KEYID", &info->read_spec[FFESTP_readixKEYID]);
- ffeste_subr_file_ ("NULLS", &info->read_spec[FFESTP_readixNULLS]);
- ffeste_subr_file_ ("REC", &info->read_spec[FFESTP_readixREC]);
- ffeste_subr_file_ ("SIZE", &info->read_spec[FFESTP_readixSIZE]);
- fputs (") ", dmpout);
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
-
- ffeste_emit_line_note_ ();
-
- {
- ffecomGfrt start;
- ffecomGfrt end;
- tree cilist;
- bool iostat;
- bool errl;
- bool endl;
-
- /* First determine the start, per-item, and end run-time functions to
- call. The per-item function is picked by choosing an ffeste function
- to call to handle a given item; it knows how to generate a call to the
- appropriate run-time function, and is called an "I/O driver". */
-
- switch (format)
- {
- case FFESTV_formatNONE: /* no FMT= */
- ffeste_io_driver_ = ffeste_io_douio_;
- if (rec)
- start = FFECOM_gfrtSRDUE, end = FFECOM_gfrtERDUE;
-#if 0
- else if (key)
- start = FFECOM_gfrtSRIUE, end = FFECOM_gfrtERIUE;
-#endif
- else
- start = FFECOM_gfrtSRSUE, end = FFECOM_gfrtERSUE;
- break;
-
- case FFESTV_formatLABEL: /* FMT=10 */
- case FFESTV_formatCHAREXPR: /* FMT='(I10)' */
- case FFESTV_formatINTEXPR: /* FMT=I [after ASSIGN 10 TO I] */
- ffeste_io_driver_ = ffeste_io_dofio_;
- if (rec)
- start = FFECOM_gfrtSRDFE, end = FFECOM_gfrtERDFE;
-#if 0
- else if (key)
- start = FFECOM_gfrtSRIFE, end = FFECOM_gfrtERIFE;
-#endif
- else if (unit == FFESTV_unitCHAREXPR)
- start = FFECOM_gfrtSRSFI, end = FFECOM_gfrtERSFI;
- else
- start = FFECOM_gfrtSRSFE, end = FFECOM_gfrtERSFE;
- break;
-
- case FFESTV_formatASTERISK: /* FMT=* */
- ffeste_io_driver_ = ffeste_io_dolio_;
- if (unit == FFESTV_unitCHAREXPR)
- start = FFECOM_gfrtSRSLI, end = FFECOM_gfrtERSLI;
- else
- start = FFECOM_gfrtSRSLE, end = FFECOM_gfrtERSLE;
- break;
-
- case FFESTV_formatNAMELIST: /* FMT=FOO or NML=FOO [NAMELIST
- /FOO/] */
- ffeste_io_driver_ = NULL; /* No start or driver function. */
- start = FFECOM_gfrtSRSNE, end = FFECOM_gfrt;
- break;
-
- default:
- assert ("Weird stuff" == NULL);
- start = FFECOM_gfrt, end = FFECOM_gfrt;
- break;
- }
- ffeste_io_endgfrt_ = end;
+ ffeste_io_endgfrt_ = end;
#define specified(something) (info->read_spec[something].kw_or_val_present)
- iostat = specified (FFESTP_readixIOSTAT);
- errl = specified (FFESTP_readixERR);
- endl = specified (FFESTP_readixEND);
+ iostat = specified (FFESTP_readixIOSTAT);
+ errl = specified (FFESTP_readixERR);
+ endl = specified (FFESTP_readixEND);
#undef specified
- ffeste_start_stmt_ ();
+ ffeste_start_stmt_ ();
- if (errl)
- {
- /* Have ERR= specification. */
+ if (errl)
+ {
+ /* Have ERR= specification. */
- ffeste_io_err_
- = ffecom_lookup_label (info->read_spec[FFESTP_readixERR].u.label);
+ ffeste_io_err_
+ = ffecom_lookup_label (info->read_spec[FFESTP_readixERR].u.label);
- if (endl)
- {
- /* Have both ERR= and END=. Need a temp label to handle both. */
- ffeste_io_end_
- = ffecom_lookup_label (info->read_spec[FFESTP_readixEND].u.label);
- ffeste_io_abort_is_temp_ = TRUE;
+ if (endl)
+ {
+ /* Have both ERR= and END=. Need a temp label to handle both. */
+ ffeste_io_end_
+ = ffecom_lookup_label (info->read_spec[FFESTP_readixEND].u.label);
+ ffeste_io_abort_is_temp_ = TRUE;
+ ffeste_io_abort_ = ffecom_temp_label ();
+ }
+ else
+ {
+ /* Have ERR= but no END=. */
+ ffeste_io_end_ = NULL_TREE;
+ if ((ffeste_io_abort_is_temp_ = iostat))
ffeste_io_abort_ = ffecom_temp_label ();
- }
- else
- {
- /* Have ERR= but no END=. */
- ffeste_io_end_ = NULL_TREE;
- if ((ffeste_io_abort_is_temp_ = iostat))
- ffeste_io_abort_ = ffecom_temp_label ();
- else
- ffeste_io_abort_ = ffeste_io_err_;
- }
- }
- else
- {
- /* No ERR= specification. */
+ else
+ ffeste_io_abort_ = ffeste_io_err_;
+ }
+ }
+ else
+ {
+ /* No ERR= specification. */
- ffeste_io_err_ = NULL_TREE;
- if (endl)
- {
- /* Have END= but no ERR=. */
- ffeste_io_end_
- = ffecom_lookup_label (info->read_spec[FFESTP_readixEND].u.label);
- if ((ffeste_io_abort_is_temp_ = iostat))
- ffeste_io_abort_ = ffecom_temp_label ();
- else
- ffeste_io_abort_ = ffeste_io_end_;
- }
- else
- {
- /* Have no ERR= or END=. */
+ ffeste_io_err_ = NULL_TREE;
+ if (endl)
+ {
+ /* Have END= but no ERR=. */
+ ffeste_io_end_
+ = ffecom_lookup_label (info->read_spec[FFESTP_readixEND].u.label);
+ if ((ffeste_io_abort_is_temp_ = iostat))
+ ffeste_io_abort_ = ffecom_temp_label ();
+ else
+ ffeste_io_abort_ = ffeste_io_end_;
+ }
+ else
+ {
+ /* Have no ERR= or END=. */
- ffeste_io_end_ = NULL_TREE;
- if ((ffeste_io_abort_is_temp_ = iostat))
- ffeste_io_abort_ = ffecom_temp_label ();
- else
- ffeste_io_abort_ = NULL_TREE;
- }
- }
+ ffeste_io_end_ = NULL_TREE;
+ if ((ffeste_io_abort_is_temp_ = iostat))
+ ffeste_io_abort_ = ffecom_temp_label ();
+ else
+ ffeste_io_abort_ = NULL_TREE;
+ }
+ }
- if (iostat)
- {
- /* Have IOSTAT= specification. */
+ if (iostat)
+ {
+ /* Have IOSTAT= specification. */
- ffeste_io_iostat_is_temp_ = FALSE;
- ffeste_io_iostat_
- = ffecom_expr (info->read_spec[FFESTP_readixIOSTAT].u.expr);
- }
- else if (ffeste_io_abort_ != NULL_TREE)
- {
- /* Have no IOSTAT= but have ERR= and/or END=. */
+ ffeste_io_iostat_is_temp_ = FALSE;
+ ffeste_io_iostat_
+ = ffecom_expr (info->read_spec[FFESTP_readixIOSTAT].u.expr);
+ }
+ else if (ffeste_io_abort_ != NULL_TREE)
+ {
+ /* Have no IOSTAT= but have ERR= and/or END=. */
- ffeste_io_iostat_is_temp_ = TRUE;
- ffeste_io_iostat_
- = ffecom_make_tempvar ("read", ffecom_integer_type_node,
- FFETARGET_charactersizeNONE, -1);
- }
- else
- {
- /* No IOSTAT=, ERR=, or END= specification. */
+ ffeste_io_iostat_is_temp_ = TRUE;
+ ffeste_io_iostat_
+ = ffecom_make_tempvar ("read", ffecom_integer_type_node,
+ FFETARGET_charactersizeNONE, -1);
+ }
+ else
+ {
+ /* No IOSTAT=, ERR=, or END= specification. */
- ffeste_io_iostat_is_temp_ = FALSE;
- ffeste_io_iostat_ = NULL_TREE;
- }
+ ffeste_io_iostat_is_temp_ = FALSE;
+ ffeste_io_iostat_ = NULL_TREE;
+ }
- /* Now prescan, then convert, all the arguments. */
-
- if (unit == FFESTV_unitCHAREXPR)
- cilist = ffeste_io_icilist_ (errl || iostat,
- info->read_spec[FFESTP_readixUNIT].u.expr,
- endl || iostat, format,
- &info->read_spec[FFESTP_readixFORMAT]);
- else
- cilist = ffeste_io_cilist_ (errl || iostat, unit,
- info->read_spec[FFESTP_readixUNIT].u.expr,
- 5, endl || iostat, format,
- &info->read_spec[FFESTP_readixFORMAT],
- rec,
- info->read_spec[FFESTP_readixREC].u.expr);
-
- /* If there is no end function, then there are no item functions (i.e.
- it's a NAMELIST), and vice versa by the way. In this situation, don't
- generate the "if (iostat != 0) goto label;" if the label is temp abort
- label, since we're gonna fall through to there anyway. */
-
- ffeste_io_call_ (ffecom_call_gfrt (start, cilist, NULL_TREE),
- (! ffeste_io_abort_is_temp_) || (end != FFECOM_gfrt));
- }
-#else
-#error
-#endif
+ /* Now prescan, then convert, all the arguments. */
+
+ if (unit == FFESTV_unitCHAREXPR)
+ cilist = ffeste_io_icilist_ (errl || iostat,
+ info->read_spec[FFESTP_readixUNIT].u.expr,
+ endl || iostat, format,
+ &info->read_spec[FFESTP_readixFORMAT]);
+ else
+ cilist = ffeste_io_cilist_ (errl || iostat, unit,
+ info->read_spec[FFESTP_readixUNIT].u.expr,
+ 5, endl || iostat, format,
+ &info->read_spec[FFESTP_readixFORMAT],
+ rec,
+ info->read_spec[FFESTP_readixREC].u.expr);
+
+ /* If there is no end function, then there are no item functions (i.e.
+ it's a NAMELIST), and vice versa by the way. In this situation, don't
+ generate the "if (iostat != 0) goto label;" if the label is temp abort
+ label, since we're gonna fall through to there anyway. */
+
+ ffeste_io_call_ (ffecom_call_gfrt (start, cilist, NULL_TREE),
+ (! ffeste_io_abort_is_temp_) || (end != FFECOM_gfrt));
}
/* READ statement -- I/O item. */
{
ffeste_check_item_ ();
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- ffebld_dump (expr);
- fputc (',', dmpout);
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
if (expr == NULL)
return;
ffeste_end_stmt_ ();
}
-#else
-#error
-#endif
}
/* READ statement -- end. */
{
ffeste_check_finish_ ();
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- fputc ('\n', dmpout);
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
-
/* Don't generate "if (iostat != 0) goto label;" if label is temp abort
label, since we're gonna fall through to there anyway. */
}
ffeste_end_stmt_ ();
-#else
-#error
-#endif
}
/* WRITE statement -- start. */
ffeste_R910_start (ffestpWriteStmt *info, ffestvUnit unit,
ffestvFormat format, bool rec)
{
+ ffecomGfrt start;
+ ffecomGfrt end;
+ tree cilist;
+ bool iostat;
+ bool errl;
+
ffeste_check_start_ ();
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
+ ffeste_emit_line_note_ ();
+
+ /* First determine the start, per-item, and end run-time functions to
+ call. The per-item function is picked by choosing an ffeste function
+ to call to handle a given item; it knows how to generate a call to the
+ appropriate run-time function, and is called an "I/O driver". */
+
switch (format)
{
- case FFESTV_formatNONE:
+ case FFESTV_formatNONE: /* no FMT= */
+ ffeste_io_driver_ = ffeste_io_douio_;
if (rec)
- fputs ("+ WRITE_ufdac (", dmpout);
+ start = FFECOM_gfrtSWDUE, end = FFECOM_gfrtEWDUE;
else
- fputs ("+ WRITE_ufseq_or_idx (", dmpout);
+ start = FFECOM_gfrtSWSUE, end = FFECOM_gfrtEWSUE;
break;
- case FFESTV_formatLABEL:
- case FFESTV_formatCHAREXPR:
- case FFESTV_formatINTEXPR:
+ case FFESTV_formatLABEL: /* FMT=10 */
+ case FFESTV_formatCHAREXPR: /* FMT='(I10)' */
+ case FFESTV_formatINTEXPR: /* FMT=I [after ASSIGN 10 TO I] */
+ ffeste_io_driver_ = ffeste_io_dofio_;
if (rec)
- fputs ("+ WRITE_fmdac (", dmpout);
+ start = FFECOM_gfrtSWDFE, end = FFECOM_gfrtEWDFE;
else if (unit == FFESTV_unitCHAREXPR)
- fputs ("+ WRITE_fmint (", dmpout);
+ start = FFECOM_gfrtSWSFI, end = FFECOM_gfrtEWSFI;
else
- fputs ("+ WRITE_fmseq_or_idx (", dmpout);
+ start = FFECOM_gfrtSWSFE, end = FFECOM_gfrtEWSFE;
break;
- case FFESTV_formatASTERISK:
+ case FFESTV_formatASTERISK: /* FMT=* */
+ ffeste_io_driver_ = ffeste_io_dolio_;
if (unit == FFESTV_unitCHAREXPR)
- fputs ("+ WRITE_lsint (", dmpout);
+ start = FFECOM_gfrtSWSLI, end = FFECOM_gfrtEWSLI;
else
- fputs ("+ WRITE_lsseq (", dmpout);
+ start = FFECOM_gfrtSWSLE, end = FFECOM_gfrtEWSLE;
break;
- case FFESTV_formatNAMELIST:
- fputs ("+ WRITE_nlseq (", dmpout);
+ case FFESTV_formatNAMELIST: /* FMT=FOO or NML=FOO [NAMELIST
+ /FOO/] */
+ ffeste_io_driver_ = NULL; /* No start or driver function. */
+ start = FFECOM_gfrtSWSNE, end = FFECOM_gfrt;
break;
default:
- assert ("Unexpected kind of format item in R910 WRITE" == NULL);
+ assert ("Weird stuff" == NULL);
+ start = FFECOM_gfrt, end = FFECOM_gfrt;
+ break;
}
-
- ffeste_subr_file_ ("UNIT", &info->write_spec[FFESTP_writeixUNIT]);
- ffeste_subr_file_ ("FORMAT", &info->write_spec[FFESTP_writeixFORMAT]);
- ffeste_subr_file_ ("ADVANCE", &info->write_spec[FFESTP_writeixADVANCE]);
- ffeste_subr_file_ ("EOR", &info->write_spec[FFESTP_writeixEOR]);
- ffeste_subr_file_ ("ERR", &info->write_spec[FFESTP_writeixERR]);
- ffeste_subr_file_ ("IOSTAT", &info->write_spec[FFESTP_writeixIOSTAT]);
- ffeste_subr_file_ ("REC", &info->write_spec[FFESTP_writeixREC]);
- fputs (") ", dmpout);
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
-
- ffeste_emit_line_note_ ();
-
- {
- ffecomGfrt start;
- ffecomGfrt end;
- tree cilist;
- bool iostat;
- bool errl;
-
- /* First determine the start, per-item, and end run-time functions to
- call. The per-item function is picked by choosing an ffeste function
- to call to handle a given item; it knows how to generate a call to the
- appropriate run-time function, and is called an "I/O driver". */
-
- switch (format)
- {
- case FFESTV_formatNONE: /* no FMT= */
- ffeste_io_driver_ = ffeste_io_douio_;
- if (rec)
- start = FFECOM_gfrtSWDUE, end = FFECOM_gfrtEWDUE;
- else
- start = FFECOM_gfrtSWSUE, end = FFECOM_gfrtEWSUE;
- break;
-
- case FFESTV_formatLABEL: /* FMT=10 */
- case FFESTV_formatCHAREXPR: /* FMT='(I10)' */
- case FFESTV_formatINTEXPR: /* FMT=I [after ASSIGN 10 TO I] */
- ffeste_io_driver_ = ffeste_io_dofio_;
- if (rec)
- start = FFECOM_gfrtSWDFE, end = FFECOM_gfrtEWDFE;
- else if (unit == FFESTV_unitCHAREXPR)
- start = FFECOM_gfrtSWSFI, end = FFECOM_gfrtEWSFI;
- else
- start = FFECOM_gfrtSWSFE, end = FFECOM_gfrtEWSFE;
- break;
-
- case FFESTV_formatASTERISK: /* FMT=* */
- ffeste_io_driver_ = ffeste_io_dolio_;
- if (unit == FFESTV_unitCHAREXPR)
- start = FFECOM_gfrtSWSLI, end = FFECOM_gfrtEWSLI;
- else
- start = FFECOM_gfrtSWSLE, end = FFECOM_gfrtEWSLE;
- break;
-
- case FFESTV_formatNAMELIST: /* FMT=FOO or NML=FOO [NAMELIST
- /FOO/] */
- ffeste_io_driver_ = NULL; /* No start or driver function. */
- start = FFECOM_gfrtSWSNE, end = FFECOM_gfrt;
- break;
-
- default:
- assert ("Weird stuff" == NULL);
- start = FFECOM_gfrt, end = FFECOM_gfrt;
- break;
- }
- ffeste_io_endgfrt_ = end;
+ ffeste_io_endgfrt_ = end;
#define specified(something) (info->write_spec[something].kw_or_val_present)
- iostat = specified (FFESTP_writeixIOSTAT);
- errl = specified (FFESTP_writeixERR);
+ iostat = specified (FFESTP_writeixIOSTAT);
+ errl = specified (FFESTP_writeixERR);
#undef specified
- ffeste_start_stmt_ ();
+ ffeste_start_stmt_ ();
- ffeste_io_end_ = NULL_TREE;
+ ffeste_io_end_ = NULL_TREE;
- if (errl)
- {
- /* Have ERR= specification. */
+ if (errl)
+ {
+ /* Have ERR= specification. */
- ffeste_io_err_
- = ffeste_io_abort_
- = ffecom_lookup_label
- (info->write_spec[FFESTP_writeixERR].u.label);
- ffeste_io_abort_is_temp_ = FALSE;
- }
- else
- {
- /* No ERR= specification. */
+ ffeste_io_err_
+ = ffeste_io_abort_
+ = ffecom_lookup_label
+ (info->write_spec[FFESTP_writeixERR].u.label);
+ ffeste_io_abort_is_temp_ = FALSE;
+ }
+ else
+ {
+ /* No ERR= specification. */
- ffeste_io_err_ = NULL_TREE;
+ ffeste_io_err_ = NULL_TREE;
- if ((ffeste_io_abort_is_temp_ = iostat))
- ffeste_io_abort_ = ffecom_temp_label ();
- else
- ffeste_io_abort_ = NULL_TREE;
- }
+ if ((ffeste_io_abort_is_temp_ = iostat))
+ ffeste_io_abort_ = ffecom_temp_label ();
+ else
+ ffeste_io_abort_ = NULL_TREE;
+ }
- if (iostat)
- {
- /* Have IOSTAT= specification. */
+ if (iostat)
+ {
+ /* Have IOSTAT= specification. */
- ffeste_io_iostat_is_temp_ = FALSE;
- ffeste_io_iostat_ = ffecom_expr
- (info->write_spec[FFESTP_writeixIOSTAT].u.expr);
- }
- else if (ffeste_io_abort_ != NULL_TREE)
- {
- /* Have no IOSTAT= but have ERR=. */
+ ffeste_io_iostat_is_temp_ = FALSE;
+ ffeste_io_iostat_ = ffecom_expr
+ (info->write_spec[FFESTP_writeixIOSTAT].u.expr);
+ }
+ else if (ffeste_io_abort_ != NULL_TREE)
+ {
+ /* Have no IOSTAT= but have ERR=. */
- ffeste_io_iostat_is_temp_ = TRUE;
- ffeste_io_iostat_
- = ffecom_make_tempvar ("write", ffecom_integer_type_node,
- FFETARGET_charactersizeNONE, -1);
- }
- else
- {
- /* No IOSTAT= or ERR= specification. */
+ ffeste_io_iostat_is_temp_ = TRUE;
+ ffeste_io_iostat_
+ = ffecom_make_tempvar ("write", ffecom_integer_type_node,
+ FFETARGET_charactersizeNONE, -1);
+ }
+ else
+ {
+ /* No IOSTAT= or ERR= specification. */
- ffeste_io_iostat_is_temp_ = FALSE;
- ffeste_io_iostat_ = NULL_TREE;
- }
+ ffeste_io_iostat_is_temp_ = FALSE;
+ ffeste_io_iostat_ = NULL_TREE;
+ }
- /* Now prescan, then convert, all the arguments. */
-
- if (unit == FFESTV_unitCHAREXPR)
- cilist = ffeste_io_icilist_ (errl || iostat,
- info->write_spec[FFESTP_writeixUNIT].u.expr,
- FALSE, format,
- &info->write_spec[FFESTP_writeixFORMAT]);
- else
- cilist = ffeste_io_cilist_ (errl || iostat, unit,
- info->write_spec[FFESTP_writeixUNIT].u.expr,
- 6, FALSE, format,
- &info->write_spec[FFESTP_writeixFORMAT],
- rec,
- info->write_spec[FFESTP_writeixREC].u.expr);
-
- /* If there is no end function, then there are no item functions (i.e.
- it's a NAMELIST), and vice versa by the way. In this situation, don't
- generate the "if (iostat != 0) goto label;" if the label is temp abort
- label, since we're gonna fall through to there anyway. */
-
- ffeste_io_call_ (ffecom_call_gfrt (start, cilist, NULL_TREE),
- (! ffeste_io_abort_is_temp_) || (end != FFECOM_gfrt));
- }
-#else
-#error
-#endif
+ /* Now prescan, then convert, all the arguments. */
+
+ if (unit == FFESTV_unitCHAREXPR)
+ cilist = ffeste_io_icilist_ (errl || iostat,
+ info->write_spec[FFESTP_writeixUNIT].u.expr,
+ FALSE, format,
+ &info->write_spec[FFESTP_writeixFORMAT]);
+ else
+ cilist = ffeste_io_cilist_ (errl || iostat, unit,
+ info->write_spec[FFESTP_writeixUNIT].u.expr,
+ 6, FALSE, format,
+ &info->write_spec[FFESTP_writeixFORMAT],
+ rec,
+ info->write_spec[FFESTP_writeixREC].u.expr);
+
+ /* If there is no end function, then there are no item functions (i.e.
+ it's a NAMELIST), and vice versa by the way. In this situation, don't
+ generate the "if (iostat != 0) goto label;" if the label is temp abort
+ label, since we're gonna fall through to there anyway. */
+
+ ffeste_io_call_ (ffecom_call_gfrt (start, cilist, NULL_TREE),
+ (! ffeste_io_abort_is_temp_) || (end != FFECOM_gfrt));
}
/* WRITE statement -- I/O item. */
{
ffeste_check_item_ ();
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- ffebld_dump (expr);
- fputc (',', dmpout);
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
if (expr == NULL)
return;
ffeste_end_stmt_ ();
}
-#else
-#error
-#endif
}
/* WRITE statement -- end. */
{
ffeste_check_finish_ ();
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- fputc ('\n', dmpout);
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
-
/* Don't generate "if (iostat != 0) goto label;" if label is temp abort
label, since we're gonna fall through to there anyway. */
}
ffeste_end_stmt_ ();
-#else
-#error
-#endif
}
/* PRINT statement -- start. */
void
ffeste_R911_start (ffestpPrintStmt *info, ffestvFormat format)
{
+ ffecomGfrt start;
+ ffecomGfrt end;
+ tree cilist;
+
ffeste_check_start_ ();
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
+ ffeste_emit_line_note_ ();
+
+ /* First determine the start, per-item, and end run-time functions to
+ call. The per-item function is picked by choosing an ffeste function
+ to call to handle a given item; it knows how to generate a call to the
+ appropriate run-time function, and is called an "I/O driver". */
+
switch (format)
{
- case FFESTV_formatLABEL:
- case FFESTV_formatCHAREXPR:
- case FFESTV_formatINTEXPR:
- fputs ("+ PRINT_fm ", dmpout);
+ case FFESTV_formatLABEL: /* FMT=10 */
+ case FFESTV_formatCHAREXPR: /* FMT='(I10)' */
+ case FFESTV_formatINTEXPR: /* FMT=I [after ASSIGN 10 TO I] */
+ ffeste_io_driver_ = ffeste_io_dofio_;
+ start = FFECOM_gfrtSWSFE, end = FFECOM_gfrtEWSFE;
break;
- case FFESTV_formatASTERISK:
- fputs ("+ PRINT_ls ", dmpout);
+ case FFESTV_formatASTERISK: /* FMT=* */
+ ffeste_io_driver_ = ffeste_io_dolio_;
+ start = FFECOM_gfrtSWSLE, end = FFECOM_gfrtEWSLE;
break;
- case FFESTV_formatNAMELIST:
- fputs ("+ PRINT_nl ", dmpout);
+ case FFESTV_formatNAMELIST: /* FMT=FOO or NML=FOO [NAMELIST
+ /FOO/] */
+ ffeste_io_driver_ = NULL; /* No start or driver function. */
+ start = FFECOM_gfrtSWSNE, end = FFECOM_gfrt;
break;
default:
- assert ("Unexpected kind of format item in R911 PRINT" == NULL);
+ assert ("Weird stuff" == NULL);
+ start = FFECOM_gfrt, end = FFECOM_gfrt;
+ break;
}
- ffeste_subr_file_ ("FORMAT", &info->print_spec[FFESTP_printixFORMAT]);
- fputc (' ', dmpout);
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
-
- ffeste_emit_line_note_ ();
-
- {
- ffecomGfrt start;
- ffecomGfrt end;
- tree cilist;
-
- /* First determine the start, per-item, and end run-time functions to
- call. The per-item function is picked by choosing an ffeste function
- to call to handle a given item; it knows how to generate a call to the
- appropriate run-time function, and is called an "I/O driver". */
-
- switch (format)
- {
- case FFESTV_formatLABEL: /* FMT=10 */
- case FFESTV_formatCHAREXPR: /* FMT='(I10)' */
- case FFESTV_formatINTEXPR: /* FMT=I [after ASSIGN 10 TO I] */
- ffeste_io_driver_ = ffeste_io_dofio_;
- start = FFECOM_gfrtSWSFE, end = FFECOM_gfrtEWSFE;
- break;
-
- case FFESTV_formatASTERISK: /* FMT=* */
- ffeste_io_driver_ = ffeste_io_dolio_;
- start = FFECOM_gfrtSWSLE, end = FFECOM_gfrtEWSLE;
- break;
-
- case FFESTV_formatNAMELIST: /* FMT=FOO or NML=FOO [NAMELIST
- /FOO/] */
- ffeste_io_driver_ = NULL; /* No start or driver function. */
- start = FFECOM_gfrtSWSNE, end = FFECOM_gfrt;
- break;
+ ffeste_io_endgfrt_ = end;
- default:
- assert ("Weird stuff" == NULL);
- start = FFECOM_gfrt, end = FFECOM_gfrt;
- break;
- }
- ffeste_io_endgfrt_ = end;
-
- ffeste_start_stmt_ ();
+ ffeste_start_stmt_ ();
- ffeste_io_end_ = NULL_TREE;
- ffeste_io_err_ = NULL_TREE;
- ffeste_io_abort_ = NULL_TREE;
- ffeste_io_abort_is_temp_ = FALSE;
- ffeste_io_iostat_is_temp_ = FALSE;
- ffeste_io_iostat_ = NULL_TREE;
+ ffeste_io_end_ = NULL_TREE;
+ ffeste_io_err_ = NULL_TREE;
+ ffeste_io_abort_ = NULL_TREE;
+ ffeste_io_abort_is_temp_ = FALSE;
+ ffeste_io_iostat_is_temp_ = FALSE;
+ ffeste_io_iostat_ = NULL_TREE;
- /* Now prescan, then convert, all the arguments. */
+ /* Now prescan, then convert, all the arguments. */
- cilist = ffeste_io_cilist_ (FALSE, FFESTV_unitNONE, NULL, 6, FALSE, format,
- &info->print_spec[FFESTP_printixFORMAT], FALSE, NULL);
+ cilist = ffeste_io_cilist_ (FALSE, FFESTV_unitNONE, NULL, 6, FALSE, format,
+ &info->print_spec[FFESTP_printixFORMAT],
+ FALSE, NULL);
- /* If there is no end function, then there are no item functions (i.e.
- it's a NAMELIST), and vice versa by the way. In this situation, don't
- generate the "if (iostat != 0) goto label;" if the label is temp abort
- label, since we're gonna fall through to there anyway. */
+ /* If there is no end function, then there are no item functions (i.e.
+ it's a NAMELIST), and vice versa by the way. In this situation, don't
+ generate the "if (iostat != 0) goto label;" if the label is temp abort
+ label, since we're gonna fall through to there anyway. */
- ffeste_io_call_ (ffecom_call_gfrt (start, cilist, NULL_TREE),
- (! ffeste_io_abort_is_temp_) || (end != FFECOM_gfrt));
- }
-#else
-#error
-#endif
+ ffeste_io_call_ (ffecom_call_gfrt (start, cilist, NULL_TREE),
+ (! ffeste_io_abort_is_temp_) || (end != FFECOM_gfrt));
}
/* PRINT statement -- I/O item. */
{
ffeste_check_item_ ();
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- ffebld_dump (expr);
- fputc (',', dmpout);
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
if (expr == NULL)
return;
ffeste_end_stmt_ ();
}
-#else
-#error
-#endif
}
/* PRINT statement -- end. */
{
ffeste_check_finish_ ();
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- fputc ('\n', dmpout);
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
-
if (ffeste_io_endgfrt_ != FFECOM_gfrt)
ffeste_io_call_ (ffecom_call_gfrt (ffeste_io_endgfrt_, NULL_TREE,
NULL_TREE),
FALSE);
ffeste_end_stmt_ ();
-#else
-#error
-#endif
}
/* BACKSPACE statement. */
{
ffeste_check_simple_ ();
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- fputs ("+ BACKSPACE (", dmpout);
- ffeste_subr_file_ ("UNIT", &info->beru_spec[FFESTP_beruixUNIT]);
- ffeste_subr_file_ ("ERR", &info->beru_spec[FFESTP_beruixERR]);
- ffeste_subr_file_ ("IOSTAT", &info->beru_spec[FFESTP_beruixIOSTAT]);
- fputs (")\n", dmpout);
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
ffeste_subr_beru_ (info, FFECOM_gfrtFBACK);
-#else
-#error
-#endif
}
/* ENDFILE statement. */
{
ffeste_check_simple_ ();
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- fputs ("+ ENDFILE (", dmpout);
- ffeste_subr_file_ ("UNIT", &info->beru_spec[FFESTP_beruixUNIT]);
- ffeste_subr_file_ ("ERR", &info->beru_spec[FFESTP_beruixERR]);
- ffeste_subr_file_ ("IOSTAT", &info->beru_spec[FFESTP_beruixIOSTAT]);
- fputs (")\n", dmpout);
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
ffeste_subr_beru_ (info, FFECOM_gfrtFEND);
-#else
-#error
-#endif
}
/* REWIND statement. */
{
ffeste_check_simple_ ();
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- fputs ("+ REWIND (", dmpout);
- ffeste_subr_file_ ("UNIT", &info->beru_spec[FFESTP_beruixUNIT]);
- ffeste_subr_file_ ("ERR", &info->beru_spec[FFESTP_beruixERR]);
- ffeste_subr_file_ ("IOSTAT", &info->beru_spec[FFESTP_beruixIOSTAT]);
- fputs (")\n", dmpout);
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
ffeste_subr_beru_ (info, FFECOM_gfrtFREW);
-#else
-#error
-#endif
}
/* INQUIRE statement (non-IOLENGTH version). */
void
ffeste_R923A (ffestpInquireStmt *info, bool by_file UNUSED)
{
+ tree args;
+ bool iostat;
+ bool errl;
+
ffeste_check_simple_ ();
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- if (by_file)
+ ffeste_emit_line_note_ ();
+
+#define specified(something) (info->inquire_spec[something].kw_or_val_present)
+
+ iostat = specified (FFESTP_inquireixIOSTAT);
+ errl = specified (FFESTP_inquireixERR);
+
+#undef specified
+
+ ffeste_start_stmt_ ();
+
+ if (errl)
+ {
+ ffeste_io_err_
+ = ffeste_io_abort_
+ = ffecom_lookup_label
+ (info->inquire_spec[FFESTP_inquireixERR].u.label);
+ ffeste_io_abort_is_temp_ = FALSE;
+ }
+ else
+ {
+ ffeste_io_err_ = NULL_TREE;
+
+ if ((ffeste_io_abort_is_temp_ = iostat))
+ ffeste_io_abort_ = ffecom_temp_label ();
+ else
+ ffeste_io_abort_ = NULL_TREE;
+ }
+
+ if (iostat)
+ {
+ /* Have IOSTAT= specification. */
+
+ ffeste_io_iostat_is_temp_ = FALSE;
+ ffeste_io_iostat_ = ffecom_expr
+ (info->inquire_spec[FFESTP_inquireixIOSTAT].u.expr);
+ }
+ else if (ffeste_io_abort_ != NULL_TREE)
{
- fputs ("+ INQUIRE_file (", dmpout);
- ffeste_subr_file_ ("FILE", &info->inquire_spec[FFESTP_inquireixFILE]);
+ /* Have no IOSTAT= but have ERR=. */
+
+ ffeste_io_iostat_is_temp_ = TRUE;
+ ffeste_io_iostat_
+ = ffecom_make_tempvar ("inquire", ffecom_integer_type_node,
+ FFETARGET_charactersizeNONE, -1);
}
else
{
- fputs ("+ INQUIRE_unit (", dmpout);
- ffeste_subr_file_ ("UNIT", &info->inquire_spec[FFESTP_inquireixUNIT]);
- }
- ffeste_subr_file_ ("ACCESS", &info->inquire_spec[FFESTP_inquireixACCESS]);
- ffeste_subr_file_ ("ACTION", &info->inquire_spec[FFESTP_inquireixACTION]);
- ffeste_subr_file_ ("BLANK", &info->inquire_spec[FFESTP_inquireixBLANK]);
- ffeste_subr_file_ ("CARRIAGECONTROL", &info->inquire_spec[FFESTP_inquireixCARRIAGECONTROL]);
- ffeste_subr_file_ ("DEFAULTFILE", &info->inquire_spec[FFESTP_inquireixDEFAULTFILE]);
- ffeste_subr_file_ ("DELIM", &info->inquire_spec[FFESTP_inquireixDELIM]);
- ffeste_subr_file_ ("DIRECT", &info->inquire_spec[FFESTP_inquireixDIRECT]);
- ffeste_subr_file_ ("ERR", &info->inquire_spec[FFESTP_inquireixERR]);
- ffeste_subr_file_ ("EXIST", &info->inquire_spec[FFESTP_inquireixEXIST]);
- ffeste_subr_file_ ("FORM", &info->inquire_spec[FFESTP_inquireixFORM]);
- ffeste_subr_file_ ("FORMATTED", &info->inquire_spec[FFESTP_inquireixFORMATTED]);
- ffeste_subr_file_ ("IOSTAT", &info->inquire_spec[FFESTP_inquireixIOSTAT]);
- ffeste_subr_file_ ("KEYED", &info->inquire_spec[FFESTP_inquireixKEYED]);
- ffeste_subr_file_ ("NAME", &info->inquire_spec[FFESTP_inquireixNAME]);
- ffeste_subr_file_ ("NAMED", &info->inquire_spec[FFESTP_inquireixNAMED]);
- ffeste_subr_file_ ("NEXTREC", &info->inquire_spec[FFESTP_inquireixNEXTREC]);
- ffeste_subr_file_ ("NUMBER", &info->inquire_spec[FFESTP_inquireixNUMBER]);
- ffeste_subr_file_ ("OPENED", &info->inquire_spec[FFESTP_inquireixOPENED]);
- ffeste_subr_file_ ("ORGANIZATION", &info->inquire_spec[FFESTP_inquireixORGANIZATION]);
- ffeste_subr_file_ ("PAD", &info->inquire_spec[FFESTP_inquireixPAD]);
- ffeste_subr_file_ ("POSITION", &info->inquire_spec[FFESTP_inquireixPOSITION]);
- ffeste_subr_file_ ("READ", &info->inquire_spec[FFESTP_inquireixREAD]);
- ffeste_subr_file_ ("READWRITE", &info->inquire_spec[FFESTP_inquireixREADWRITE]);
- ffeste_subr_file_ ("RECL", &info->inquire_spec[FFESTP_inquireixRECL]);
- ffeste_subr_file_ ("RECORDTYPE", &info->inquire_spec[FFESTP_inquireixRECORDTYPE]);
- ffeste_subr_file_ ("SEQUENTIAL", &info->inquire_spec[FFESTP_inquireixSEQUENTIAL]);
- ffeste_subr_file_ ("UNFORMATTED", &info->inquire_spec[FFESTP_inquireixUNFORMATTED]);
- ffeste_subr_file_ ("WRITE", &info->inquire_spec[FFESTP_inquireixWRITE]);
- fputs (")\n", dmpout);
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
- {
- tree args;
- bool iostat;
- bool errl;
-
- ffeste_emit_line_note_ ();
-
-#define specified(something) (info->inquire_spec[something].kw_or_val_present)
-
- iostat = specified (FFESTP_inquireixIOSTAT);
- errl = specified (FFESTP_inquireixERR);
-
-#undef specified
-
- ffeste_start_stmt_ ();
-
- if (errl)
- {
- ffeste_io_err_
- = ffeste_io_abort_
- = ffecom_lookup_label
- (info->inquire_spec[FFESTP_inquireixERR].u.label);
- ffeste_io_abort_is_temp_ = FALSE;
- }
- else
- {
- ffeste_io_err_ = NULL_TREE;
-
- if ((ffeste_io_abort_is_temp_ = iostat))
- ffeste_io_abort_ = ffecom_temp_label ();
- else
- ffeste_io_abort_ = NULL_TREE;
- }
-
- if (iostat)
- {
- /* Have IOSTAT= specification. */
+ /* No IOSTAT= or ERR= specification. */
- ffeste_io_iostat_is_temp_ = FALSE;
- ffeste_io_iostat_ = ffecom_expr
- (info->inquire_spec[FFESTP_inquireixIOSTAT].u.expr);
- }
- else if (ffeste_io_abort_ != NULL_TREE)
- {
- /* Have no IOSTAT= but have ERR=. */
+ ffeste_io_iostat_is_temp_ = FALSE;
+ ffeste_io_iostat_ = NULL_TREE;
+ }
- ffeste_io_iostat_is_temp_ = TRUE;
- ffeste_io_iostat_
- = ffecom_make_tempvar ("inquire", ffecom_integer_type_node,
- FFETARGET_charactersizeNONE, -1);
- }
- else
- {
- /* No IOSTAT= or ERR= specification. */
+ /* Now prescan, then convert, all the arguments. */
- ffeste_io_iostat_is_temp_ = FALSE;
- ffeste_io_iostat_ = NULL_TREE;
- }
+ args
+ = ffeste_io_inlist_ (errl || iostat,
+ &info->inquire_spec[FFESTP_inquireixUNIT],
+ &info->inquire_spec[FFESTP_inquireixFILE],
+ &info->inquire_spec[FFESTP_inquireixEXIST],
+ &info->inquire_spec[FFESTP_inquireixOPENED],
+ &info->inquire_spec[FFESTP_inquireixNUMBER],
+ &info->inquire_spec[FFESTP_inquireixNAMED],
+ &info->inquire_spec[FFESTP_inquireixNAME],
+ &info->inquire_spec[FFESTP_inquireixACCESS],
+ &info->inquire_spec[FFESTP_inquireixSEQUENTIAL],
+ &info->inquire_spec[FFESTP_inquireixDIRECT],
+ &info->inquire_spec[FFESTP_inquireixFORM],
+ &info->inquire_spec[FFESTP_inquireixFORMATTED],
+ &info->inquire_spec[FFESTP_inquireixUNFORMATTED],
+ &info->inquire_spec[FFESTP_inquireixRECL],
+ &info->inquire_spec[FFESTP_inquireixNEXTREC],
+ &info->inquire_spec[FFESTP_inquireixBLANK]);
- /* Now prescan, then convert, all the arguments. */
-
- args
- = ffeste_io_inlist_ (errl || iostat,
- &info->inquire_spec[FFESTP_inquireixUNIT],
- &info->inquire_spec[FFESTP_inquireixFILE],
- &info->inquire_spec[FFESTP_inquireixEXIST],
- &info->inquire_spec[FFESTP_inquireixOPENED],
- &info->inquire_spec[FFESTP_inquireixNUMBER],
- &info->inquire_spec[FFESTP_inquireixNAMED],
- &info->inquire_spec[FFESTP_inquireixNAME],
- &info->inquire_spec[FFESTP_inquireixACCESS],
- &info->inquire_spec[FFESTP_inquireixSEQUENTIAL],
- &info->inquire_spec[FFESTP_inquireixDIRECT],
- &info->inquire_spec[FFESTP_inquireixFORM],
- &info->inquire_spec[FFESTP_inquireixFORMATTED],
- &info->inquire_spec[FFESTP_inquireixUNFORMATTED],
- &info->inquire_spec[FFESTP_inquireixRECL],
- &info->inquire_spec[FFESTP_inquireixNEXTREC],
- &info->inquire_spec[FFESTP_inquireixBLANK]);
-
- /* Don't generate "if (iostat != 0) goto label;" if label is temp abort
- label, since we're gonna fall through to there anyway. */
+ /* Don't generate "if (iostat != 0) goto label;" if label is temp abort
+ label, since we're gonna fall through to there anyway. */
- ffeste_io_call_ (ffecom_call_gfrt (FFECOM_gfrtFINQU, args, NULL_TREE),
- ! ffeste_io_abort_is_temp_);
+ ffeste_io_call_ (ffecom_call_gfrt (FFECOM_gfrtFINQU, args, NULL_TREE),
+ ! ffeste_io_abort_is_temp_);
- /* If we've got a temp label, generate its code here. */
+ /* If we've got a temp label, generate its code here. */
- if (ffeste_io_abort_is_temp_)
- {
- DECL_INITIAL (ffeste_io_abort_) = error_mark_node;
- emit_nop ();
- expand_label (ffeste_io_abort_);
+ if (ffeste_io_abort_is_temp_)
+ {
+ DECL_INITIAL (ffeste_io_abort_) = error_mark_node;
+ emit_nop ();
+ expand_label (ffeste_io_abort_);
- assert (ffeste_io_err_ == NULL_TREE);
- }
+ assert (ffeste_io_err_ == NULL_TREE);
+ }
- ffeste_end_stmt_ ();
- }
-#else
-#error
-#endif
+ ffeste_end_stmt_ ();
}
/* INQUIRE(IOLENGTH=expr) statement -- start. */
{
ffeste_check_start_ ();
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- fputs ("+ INQUIRE (", dmpout);
- ffeste_subr_file_ ("IOLENGTH", &info->inquire_spec[FFESTP_inquireixIOLENGTH]);
- fputs (") ", dmpout);
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
assert ("INQUIRE(IOLENGTH=<var>) not implemented yet! ~~~" == NULL);
ffeste_emit_line_note_ ();
-#else
-#error
-#endif
}
/* INQUIRE(IOLENGTH=expr) statement -- I/O item. */
ffeste_R923B_item (ffebld expr UNUSED)
{
ffeste_check_item_ ();
-
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- ffebld_dump (expr);
- fputc (',', dmpout);
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
-#else
-#error
-#endif
}
/* INQUIRE(IOLENGTH=expr) statement -- end. */
ffeste_R923B_finish ()
{
ffeste_check_finish_ ();
-
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- fputc ('\n', dmpout);
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
-#else
-#error
-#endif
}
/* ffeste_R1001 -- FORMAT statement
void
ffeste_R1001 (ffests s)
{
- ffeste_check_simple_ ();
+ tree t;
+ tree ttype;
+ tree maxindex;
+ tree var;
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- fprintf (dmpout, "$ FORMAT %.*s\n", (int) ffests_length (s), ffests_text (s));
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
- {
- tree t;
- tree ttype;
- tree maxindex;
- tree var;
+ ffeste_check_simple_ ();
- assert (ffeste_label_formatdef_ != NULL);
+ assert (ffeste_label_formatdef_ != NULL);
- ffeste_emit_line_note_ ();
+ ffeste_emit_line_note_ ();
- t = build_string (ffests_length (s), ffests_text (s));
+ t = build_string (ffests_length (s), ffests_text (s));
- TREE_TYPE (t)
- = build_type_variant (build_array_type
- (char_type_node,
- build_range_type (integer_type_node,
- integer_one_node,
+ TREE_TYPE (t)
+ = build_type_variant (build_array_type
+ (char_type_node,
+ build_range_type (integer_type_node,
+ integer_one_node,
build_int_2 (ffests_length (s),
0))),
- 1, 0);
- TREE_CONSTANT (t) = 1;
- TREE_STATIC (t) = 1;
+ 1, 0);
+ TREE_CONSTANT (t) = 1;
+ TREE_STATIC (t) = 1;
- var = ffecom_lookup_label (ffeste_label_formatdef_);
- if ((var != NULL_TREE)
- && (TREE_CODE (var) == VAR_DECL))
- {
- DECL_INITIAL (var) = t;
- maxindex = build_int_2 (ffests_length (s) - 1, 0);
- ttype = TREE_TYPE (var);
- TYPE_DOMAIN (ttype) = build_range_type (integer_type_node,
- integer_zero_node,
- maxindex);
- if (!TREE_TYPE (maxindex))
- TREE_TYPE (maxindex) = TYPE_DOMAIN (ttype);
- layout_type (ttype);
- rest_of_decl_compilation (var, NULL, 1, 0);
- expand_decl (var);
- expand_decl_init (var);
- }
+ var = ffecom_lookup_label (ffeste_label_formatdef_);
+ if ((var != NULL_TREE)
+ && (TREE_CODE (var) == VAR_DECL))
+ {
+ DECL_INITIAL (var) = t;
+ maxindex = build_int_2 (ffests_length (s) - 1, 0);
+ ttype = TREE_TYPE (var);
+ TYPE_DOMAIN (ttype) = build_range_type (integer_type_node,
+ integer_zero_node,
+ maxindex);
+ if (!TREE_TYPE (maxindex))
+ TREE_TYPE (maxindex) = TYPE_DOMAIN (ttype);
+ layout_type (ttype);
+ rest_of_decl_compilation (var, NULL, 1, 0);
+ expand_decl (var);
+ expand_decl_init (var);
+ }
- ffeste_label_formatdef_ = NULL;
- }
-#else
-#error
-#endif
+ ffeste_label_formatdef_ = NULL;
}
/* END PROGRAM. */
void
ffeste_R1103 ()
{
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- fputs ("+ END_PROGRAM\n", dmpout);
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
-#else
-#error
-#endif
}
/* END BLOCK DATA. */
void
ffeste_R1112 ()
{
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- fputs ("* END_BLOCK_DATA\n", dmpout);
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
-#else
-#error
-#endif
}
/* CALL statement. */
void
ffeste_R1212 (ffebld expr)
{
+ ffebld args;
+ ffebld arg;
+ ffebld labels = NULL; /* First in list of LABTERs. */
+ ffebld prevlabels = NULL;
+ ffebld prevargs = NULL;
+
ffeste_check_simple_ ();
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- fputs ("+ CALL ", dmpout);
- ffebld_dump (expr);
- fputc ('\n', dmpout);
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
- {
- ffebld args = ffebld_right (expr);
- ffebld arg;
- ffebld labels = NULL; /* First in list of LABTERs. */
- ffebld prevlabels = NULL;
- ffebld prevargs = NULL;
+ args = ffebld_right (expr);
- ffeste_emit_line_note_ ();
+ ffeste_emit_line_note_ ();
- /* Here we split the list at ffebld_right(expr) into two lists: one at
- ffebld_right(expr) consisting of all items that are not LABTERs, the
- other at labels consisting of all items that are LABTERs. Then, if
- the latter list is NULL, we have an ordinary call, else we have a call
- with alternate returns. */
+ /* Here we split the list at ffebld_right(expr) into two lists: one at
+ ffebld_right(expr) consisting of all items that are not LABTERs, the
+ other at labels consisting of all items that are LABTERs. Then, if
+ the latter list is NULL, we have an ordinary call, else we have a call
+ with alternate returns. */
- for (args = ffebld_right (expr); args != NULL; args = ffebld_trail (args))
- {
- if (((arg = ffebld_head (args)) == NULL)
- || (ffebld_op (arg) != FFEBLD_opLABTER))
- {
- if (prevargs == NULL)
- {
- prevargs = args;
- ffebld_set_right (expr, args);
- }
- else
- {
- ffebld_set_trail (prevargs, args);
- prevargs = args;
- }
- }
- else
- {
- if (prevlabels == NULL)
- {
- prevlabels = labels = args;
- }
- else
- {
- ffebld_set_trail (prevlabels, args);
- prevlabels = args;
- }
- }
- }
- if (prevlabels == NULL)
- labels = NULL;
- else
- ffebld_set_trail (prevlabels, NULL);
- if (prevargs == NULL)
- ffebld_set_right (expr, NULL);
- else
- ffebld_set_trail (prevargs, NULL);
+ for (args = ffebld_right (expr); args != NULL; args = ffebld_trail (args))
+ {
+ if (((arg = ffebld_head (args)) == NULL)
+ || (ffebld_op (arg) != FFEBLD_opLABTER))
+ {
+ if (prevargs == NULL)
+ {
+ prevargs = args;
+ ffebld_set_right (expr, args);
+ }
+ else
+ {
+ ffebld_set_trail (prevargs, args);
+ prevargs = args;
+ }
+ }
+ else
+ {
+ if (prevlabels == NULL)
+ {
+ prevlabels = labels = args;
+ }
+ else
+ {
+ ffebld_set_trail (prevlabels, args);
+ prevlabels = args;
+ }
+ }
+ }
+ if (prevlabels == NULL)
+ labels = NULL;
+ else
+ ffebld_set_trail (prevlabels, NULL);
+ if (prevargs == NULL)
+ ffebld_set_right (expr, NULL);
+ else
+ ffebld_set_trail (prevargs, NULL);
- ffeste_start_stmt_ ();
+ ffeste_start_stmt_ ();
- /* No temporaries are actually needed at this level, but we go
- through the motions anyway, just to be sure in case they do
- get made. Temporaries needed for arguments should be in the
- scopes of inner blocks, and if clean-up actions are supported,
- such as CALL-ing an intrinsic that writes to an argument of one
- type when a variable of a different type is provided (requiring
- assignment to the variable from a temporary after the library
- routine returns), the clean-up must be done by the expression
- evaluator, generally, to handle alternate returns (which we hope
- won't ever be supported by intrinsics, but might be a similar
- issue, such as CALL-ing an F90-style subroutine with an INTERFACE
- block). That implies the expression evaluator will have to
- recognize the need for its own temporary anyway, meaning it'll
- construct a block within the one constructed here. */
-
- ffecom_prepare_expr (expr);
-
- ffecom_prepare_end ();
-
- if (labels == NULL)
- expand_expr_stmt (ffecom_expr (expr));
- else
- {
- tree texpr;
- tree value;
- tree tlabel;
- int caseno;
- int pushok;
- tree duplicate;
- ffebld label;
-
- texpr = ffecom_expr (expr);
- expand_start_case (0, texpr, TREE_TYPE (texpr), "CALL statement");
-
- for (caseno = 1, label = labels;
- label != NULL;
- ++caseno, label = ffebld_trail (label))
- {
- value = build_int_2 (caseno, 0);
- tlabel = build_decl (LABEL_DECL, NULL_TREE, NULL_TREE);
-
- pushok = pushcase (value, convert, tlabel, &duplicate);
- assert (pushok == 0);
-
- tlabel
- = ffecom_lookup_label (ffebld_labter (ffebld_head (label)));
- if ((tlabel == NULL_TREE)
- || (TREE_CODE (tlabel) == ERROR_MARK))
- continue;
- TREE_USED (tlabel) = 1;
- expand_goto (tlabel);
- }
+ /* No temporaries are actually needed at this level, but we go
+ through the motions anyway, just to be sure in case they do
+ get made. Temporaries needed for arguments should be in the
+ scopes of inner blocks, and if clean-up actions are supported,
+ such as CALL-ing an intrinsic that writes to an argument of one
+ type when a variable of a different type is provided (requiring
+ assignment to the variable from a temporary after the library
+ routine returns), the clean-up must be done by the expression
+ evaluator, generally, to handle alternate returns (which we hope
+ won't ever be supported by intrinsics, but might be a similar
+ issue, such as CALL-ing an F90-style subroutine with an INTERFACE
+ block). That implies the expression evaluator will have to
+ recognize the need for its own temporary anyway, meaning it'll
+ construct a block within the one constructed here. */
+
+ ffecom_prepare_expr (expr);
- expand_end_case (texpr);
- }
+ ffecom_prepare_end ();
- ffeste_end_stmt_ ();
- }
-#else
-#error
-#endif
+ if (labels == NULL)
+ expand_expr_stmt (ffecom_expr (expr));
+ else
+ {
+ tree texpr;
+ tree value;
+ tree tlabel;
+ int caseno;
+ int pushok;
+ tree duplicate;
+ ffebld label;
+
+ texpr = ffecom_expr (expr);
+ expand_start_case (0, texpr, TREE_TYPE (texpr), "CALL statement");
+
+ for (caseno = 1, label = labels;
+ label != NULL;
+ ++caseno, label = ffebld_trail (label))
+ {
+ value = build_int_2 (caseno, 0);
+ tlabel = build_decl (LABEL_DECL, NULL_TREE, NULL_TREE);
+
+ pushok = pushcase (value, convert, tlabel, &duplicate);
+ assert (pushok == 0);
+
+ tlabel
+ = ffecom_lookup_label (ffebld_labter (ffebld_head (label)));
+ if ((tlabel == NULL_TREE)
+ || (TREE_CODE (tlabel) == ERROR_MARK))
+ continue;
+ TREE_USED (tlabel) = 1;
+ expand_goto (tlabel);
+ }
+
+ expand_end_case (texpr);
+ }
+
+ ffeste_end_stmt_ ();
}
/* END FUNCTION. */
void
ffeste_R1221 ()
{
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- fputs ("+ END_FUNCTION\n", dmpout);
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
-#else
-#error
-#endif
}
/* END SUBROUTINE. */
void
ffeste_R1225 ()
{
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- fprintf (dmpout, "+ END_SUBROUTINE\n");
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
-#else
-#error
-#endif
}
/* ENTRY statement. */
void
ffeste_R1226 (ffesymbol entry)
{
- ffeste_check_simple_ ();
+ tree label;
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- fprintf (dmpout, "+ ENTRY %s", ffesymbol_text (entry));
- if (ffesymbol_dummyargs (entry) != NULL)
- {
- ffebld argh;
+ ffeste_check_simple_ ();
- fputc ('(', dmpout);
- for (argh = ffesymbol_dummyargs (entry);
- argh != NULL;
- argh = ffebld_trail (argh))
- {
- assert (ffebld_head (argh) != NULL);
- switch (ffebld_op (ffebld_head (argh)))
- {
- case FFEBLD_opSYMTER:
- fputs (ffesymbol_text (ffebld_symter (ffebld_head (argh))),
- dmpout);
- break;
-
- case FFEBLD_opSTAR:
- fputc ('*', dmpout);
- break;
-
- default:
- fputc ('?', dmpout);
- ffebld_dump (ffebld_head (argh));
- fputc ('?', dmpout);
- break;
- }
- if (ffebld_trail (argh) != NULL)
- fputc (',', dmpout);
- }
- fputc (')', dmpout);
- }
- fputc ('\n', dmpout);
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
- {
- tree label = ffesymbol_hook (entry).length_tree;
+ label = ffesymbol_hook (entry).length_tree;
- ffeste_emit_line_note_ ();
+ ffeste_emit_line_note_ ();
- if (label == error_mark_node)
- return;
+ if (label == error_mark_node)
+ return;
- DECL_INITIAL (label) = error_mark_node;
- emit_nop ();
- expand_label (label);
- }
-#else
-#error
-#endif
+ DECL_INITIAL (label) = error_mark_node;
+ emit_nop ();
+ expand_label (label);
}
/* RETURN statement. */
void
ffeste_R1227 (ffestw block UNUSED, ffebld expr)
{
- ffeste_check_simple_ ();
+ tree rtn;
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- if (expr == NULL)
- {
- fputs ("+ RETURN\n", dmpout);
- }
- else
- {
- fputs ("+ RETURN_alternate ", dmpout);
- ffebld_dump (expr);
- fputc ('\n', dmpout);
- }
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
- {
- tree rtn;
+ ffeste_check_simple_ ();
- ffeste_emit_line_note_ ();
+ ffeste_emit_line_note_ ();
- ffeste_start_stmt_ ();
+ ffeste_start_stmt_ ();
- ffecom_prepare_return_expr (expr);
+ ffecom_prepare_return_expr (expr);
- ffecom_prepare_end ();
+ ffecom_prepare_end ();
- rtn = ffecom_return_expr (expr);
+ rtn = ffecom_return_expr (expr);
- if ((rtn == NULL_TREE)
- || (rtn == error_mark_node))
- expand_null_return ();
- else
- {
- tree result = DECL_RESULT (current_function_decl);
-
- if ((result != error_mark_node)
- && (TREE_TYPE (result) != error_mark_node))
- expand_return (ffecom_modify (NULL_TREE,
- result,
- convert (TREE_TYPE (result),
- rtn)));
- else
- expand_null_return ();
- }
+ if ((rtn == NULL_TREE)
+ || (rtn == error_mark_node))
+ expand_null_return ();
+ else
+ {
+ tree result = DECL_RESULT (current_function_decl);
+
+ if ((result != error_mark_node)
+ && (TREE_TYPE (result) != error_mark_node))
+ expand_return (ffecom_modify (NULL_TREE,
+ result,
+ convert (TREE_TYPE (result),
+ rtn)));
+ else
+ expand_null_return ();
+ }
- ffeste_end_stmt_ ();
- }
-#else
-#error
-#endif
+ ffeste_end_stmt_ ();
}
/* REWRITE statement -- start. */
ffeste_V018_start (ffestpRewriteStmt *info, ffestvFormat format)
{
ffeste_check_start_ ();
-
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- switch (format)
- {
- case FFESTV_formatNONE:
- fputs ("+ REWRITE_uf (", dmpout);
- break;
-
- case FFESTV_formatLABEL:
- case FFESTV_formatCHAREXPR:
- case FFESTV_formatINTEXPR:
- fputs ("+ REWRITE_fm (", dmpout);
- break;
-
- default:
- assert ("Unexpected kind of format item in V018 REWRITE" == NULL);
- }
- ffeste_subr_file_ ("UNIT", &info->rewrite_spec[FFESTP_rewriteixUNIT]);
- ffeste_subr_file_ ("FMT", &info->rewrite_spec[FFESTP_rewriteixFMT]);
- ffeste_subr_file_ ("ERR", &info->rewrite_spec[FFESTP_rewriteixERR]);
- ffeste_subr_file_ ("IOSTAT", &info->rewrite_spec[FFESTP_rewriteixIOSTAT]);
- fputs (") ", dmpout);
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
-#else
-#error
-#endif
}
/* REWRITE statement -- I/O item. */
ffeste_V018_item (ffebld expr)
{
ffeste_check_item_ ();
-
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- ffebld_dump (expr);
- fputc (',', dmpout);
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
-#else
-#error
-#endif
}
/* REWRITE statement -- end. */
ffeste_V018_finish ()
{
ffeste_check_finish_ ();
-
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- fputc ('\n', dmpout);
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
-#else
-#error
-#endif
}
/* ACCEPT statement -- start. */
ffeste_V019_start (ffestpAcceptStmt *info, ffestvFormat format)
{
ffeste_check_start_ ();
-
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- switch (format)
- {
- case FFESTV_formatLABEL:
- case FFESTV_formatCHAREXPR:
- case FFESTV_formatINTEXPR:
- fputs ("+ ACCEPT_fm ", dmpout);
- break;
-
- case FFESTV_formatASTERISK:
- fputs ("+ ACCEPT_ls ", dmpout);
- break;
-
- case FFESTV_formatNAMELIST:
- fputs ("+ ACCEPT_nl ", dmpout);
- break;
-
- default:
- assert ("Unexpected kind of format item in V019 ACCEPT" == NULL);
- }
- ffeste_subr_file_ ("FORMAT", &info->accept_spec[FFESTP_acceptixFORMAT]);
- fputc (' ', dmpout);
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
-#else
-#error
-#endif
}
/* ACCEPT statement -- I/O item. */
ffeste_V019_item (ffebld expr)
{
ffeste_check_item_ ();
-
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- ffebld_dump (expr);
- fputc (',', dmpout);
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
-#else
-#error
-#endif
}
/* ACCEPT statement -- end. */
ffeste_V019_finish ()
{
ffeste_check_finish_ ();
-
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- fputc ('\n', dmpout);
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
-#else
-#error
-#endif
}
#endif
ffestvFormat format UNUSED)
{
ffeste_check_start_ ();
-
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- switch (format)
- {
- case FFESTV_formatLABEL:
- case FFESTV_formatCHAREXPR:
- case FFESTV_formatINTEXPR:
- fputs ("+ TYPE_fm ", dmpout);
- break;
-
- case FFESTV_formatASTERISK:
- fputs ("+ TYPE_ls ", dmpout);
- break;
-
- case FFESTV_formatNAMELIST:
- fputs ("* TYPE_nl ", dmpout);
- break;
-
- default:
- assert ("Unexpected kind of format item in V020 TYPE" == NULL);
- }
- ffeste_subr_file_ ("FORMAT", &info->type_spec[FFESTP_typeixFORMAT]);
- fputc (' ', dmpout);
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
-#else
-#error
-#endif
}
/* TYPE statement -- I/O item. */
ffeste_V020_item (ffebld expr UNUSED)
{
ffeste_check_item_ ();
-
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- ffebld_dump (expr);
- fputc (',', dmpout);
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
-#else
-#error
-#endif
}
/* TYPE statement -- end. */
ffeste_V020_finish ()
{
ffeste_check_finish_ ();
-
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- fputc ('\n', dmpout);
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
-#else
-#error
-#endif
}
/* DELETE statement. */
ffeste_V021 (ffestpDeleteStmt *info)
{
ffeste_check_simple_ ();
-
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- fputs ("+ DELETE (", dmpout);
- ffeste_subr_file_ ("UNIT", &info->delete_spec[FFESTP_deleteixUNIT]);
- ffeste_subr_file_ ("REC", &info->delete_spec[FFESTP_deleteixREC]);
- ffeste_subr_file_ ("ERR", &info->delete_spec[FFESTP_deleteixERR]);
- ffeste_subr_file_ ("IOSTAT", &info->delete_spec[FFESTP_deleteixIOSTAT]);
- fputs (")\n", dmpout);
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
-#else
-#error
-#endif
}
/* UNLOCK statement. */
ffeste_V022 (ffestpBeruStmt *info)
{
ffeste_check_simple_ ();
-
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- fputs ("+ UNLOCK (", dmpout);
- ffeste_subr_file_ ("UNIT", &info->beru_spec[FFESTP_beruixUNIT]);
- ffeste_subr_file_ ("ERR", &info->beru_spec[FFESTP_beruixERR]);
- ffeste_subr_file_ ("IOSTAT", &info->beru_spec[FFESTP_beruixIOSTAT]);
- fputs (")\n", dmpout);
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
-#else
-#error
-#endif
}
/* ENCODE statement -- start. */
ffeste_V023_start (ffestpVxtcodeStmt *info)
{
ffeste_check_start_ ();
-
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- fputs ("+ ENCODE (", dmpout);
- ffeste_subr_file_ ("C", &info->vxtcode_spec[FFESTP_vxtcodeixC]);
- ffeste_subr_file_ ("F", &info->vxtcode_spec[FFESTP_vxtcodeixF]);
- ffeste_subr_file_ ("B", &info->vxtcode_spec[FFESTP_vxtcodeixB]);
- ffeste_subr_file_ ("ERR", &info->vxtcode_spec[FFESTP_vxtcodeixERR]);
- ffeste_subr_file_ ("IOSTAT", &info->vxtcode_spec[FFESTP_vxtcodeixIOSTAT]);
- fputs (") ", dmpout);
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
-#else
-#error
-#endif
}
/* ENCODE statement -- I/O item. */
ffeste_V023_item (ffebld expr)
{
ffeste_check_item_ ();
-
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- ffebld_dump (expr);
- fputc (',', dmpout);
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
-#else
-#error
-#endif
}
/* ENCODE statement -- end. */
ffeste_V023_finish ()
{
ffeste_check_finish_ ();
-
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- fputc ('\n', dmpout);
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
-#else
-#error
-#endif
}
/* DECODE statement -- start. */
ffeste_V024_start (ffestpVxtcodeStmt *info)
{
ffeste_check_start_ ();
-
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- fputs ("+ DECODE (", dmpout);
- ffeste_subr_file_ ("C", &info->vxtcode_spec[FFESTP_vxtcodeixC]);
- ffeste_subr_file_ ("F", &info->vxtcode_spec[FFESTP_vxtcodeixF]);
- ffeste_subr_file_ ("B", &info->vxtcode_spec[FFESTP_vxtcodeixB]);
- ffeste_subr_file_ ("ERR", &info->vxtcode_spec[FFESTP_vxtcodeixERR]);
- ffeste_subr_file_ ("IOSTAT", &info->vxtcode_spec[FFESTP_vxtcodeixIOSTAT]);
- fputs (") ", dmpout);
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
-#else
-#error
-#endif
}
/* DECODE statement -- I/O item. */
ffeste_V024_item (ffebld expr)
{
ffeste_check_item_ ();
-
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- ffebld_dump (expr);
- fputc (',', dmpout);
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
-#else
-#error
-#endif
}
/* DECODE statement -- end. */
ffeste_V024_finish ()
{
ffeste_check_finish_ ();
-
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- fputc ('\n', dmpout);
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
-#else
-#error
-#endif
}
/* DEFINEFILE statement -- start. */
ffeste_V025_start ()
{
ffeste_check_start_ ();
-
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- fputs ("+ DEFINE_FILE ", dmpout);
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
-#else
-#error
-#endif
}
/* DEFINE FILE statement -- item. */
ffeste_V025_item (ffebld u, ffebld m, ffebld n, ffebld asv)
{
ffeste_check_item_ ();
-
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- ffebld_dump (u);
- fputc ('(', dmpout);
- ffebld_dump (m);
- fputc (',', dmpout);
- ffebld_dump (n);
- fputs (",U,", dmpout);
- ffebld_dump (asv);
- fputs ("),", dmpout);
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
-#else
-#error
-#endif
}
/* DEFINE FILE statement -- end. */
ffeste_V025_finish ()
{
ffeste_check_finish_ ();
-
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- fputc ('\n', dmpout);
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
-#else
-#error
-#endif
}
/* FIND statement. */
ffeste_V026 (ffestpFindStmt *info)
{
ffeste_check_simple_ ();
-
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
- fputs ("+ FIND (", dmpout);
- ffeste_subr_file_ ("UNIT", &info->find_spec[FFESTP_findixUNIT]);
- ffeste_subr_file_ ("REC", &info->find_spec[FFESTP_findixREC]);
- ffeste_subr_file_ ("ERR", &info->find_spec[FFESTP_findixERR]);
- ffeste_subr_file_ ("IOSTAT", &info->find_spec[FFESTP_findixIOSTAT]);
- fputs (")\n", dmpout);
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
-#else
-#error
-#endif
}
#endif
#define ffeste_init_2()
#define ffeste_init_3()
#define ffeste_init_4()
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
#define ffeste_filename() input_filename
#define ffeste_filelinenum() lineno
#define ffeste_set_line(name,num) \
(input_filename = (name), lineno = (num))
-#elif FFECOM_targetCURRENT == FFECOM_targetFFE
-#define ffeste_set_line(name,num)
-#else
-#error
-#endif /* FFECOM_targetCURRENT == FFECOM_targetFFE */
#define ffeste_terminate_0()
#define ffeste_terminate_1()
#ifdef ENABLE_CHECKING
return new;
}
-/* ffestt_caselist_dump -- Dump list of cases
-
- ffesttCaseList list;
- ffestt_caselist_dump(list);
-
- The cases in the list are dumped with commas separating them. */
-
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
-void
-ffestt_caselist_dump (ffesttCaseList list)
-{
- ffesttCaseList next;
-
- for (next = list->next; next != list; next = next->next)
- {
- if (next != list->next)
- fputc (',', dmpout);
- if (next->expr1 != NULL)
- ffebld_dump (next->expr1);
- if (next->range)
- {
- fputc (':', dmpout);
- if (next->expr2 != NULL)
- ffebld_dump (next->expr2);
- }
- }
-}
-#endif
-
/* ffestt_caselist_kill -- Kill list of cases
ffesttCaseList list;
return new;
}
-/* ffestt_dimlist_dump -- Dump list of dims
-
- ffesttDimList list;
- ffestt_dimlist_dump(list);
-
- The dims in the list are dumped with commas separating them. */
-
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
-void
-ffestt_dimlist_dump (ffesttDimList list)
-{
- ffesttDimList next;
-
- for (next = list->next; next != list; next = next->next)
- {
- if (next != list->next)
- fputc (',', dmpout);
- if (next->lower != NULL)
- ffebld_dump (next->lower);
- fputc (':', dmpout);
- if (next->upper != NULL)
- ffebld_dump (next->upper);
- }
-}
-#endif
-
/* ffestt_dimlist_kill -- Kill list of dims
ffesttDimList list;
}
}
-/* ffestt_exprlist_dump -- Dump list of exprs
-
- ffesttExprList list;
- ffestt_exprlist_dump(list);
-
- The exprs in the list are dumped with commas separating them. */
-
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
-void
-ffestt_exprlist_dump (ffesttExprList list)
-{
- ffesttExprList next;
-
- for (next = list->next; next != list; next = next->next)
- {
- if (next != list->next)
- fputc (',', dmpout);
- ffebld_dump (next->expr);
- }
-}
-#endif
-
/* ffestt_exprlist_kill -- Kill list of exprs
ffesttExprList list;
}
}
-/* ffestt_implist_dump -- Dump list of token pairs
-
- ffesttImpList list;
- ffestt_implist_dump(list);
-
- The token pairs in the list are dumped with commas separating them. */
-
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
-void
-ffestt_implist_dump (ffesttImpList list)
-{
- ffesttImpList next;
-
- for (next = list->next; next != list; next = next->next)
- {
- if (next != list->next)
- fputc (',', dmpout);
- assert (ffelex_token_type (next->first) == FFELEX_typeNAME);
- fputs (ffelex_token_text (next->first), dmpout);
- if (next->last != NULL)
- {
- fputc ('-', dmpout);
- assert (ffelex_token_type (next->last) == FFELEX_typeNAME);
- fputs (ffelex_token_text (next->last), dmpout);
- }
- }
-}
-#endif
-
/* ffestt_implist_kill -- Kill list of token pairs
ffesttImpList list;
}
}
-/* ffestt_tokenlist_dump -- Dump list of tokens
-
- ffesttTokenList tl;
- ffestt_tokenlist_dump(tl);
-
- The tokens in the list are dumped with commas separating them. */
-
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
-void
-ffestt_tokenlist_dump (ffesttTokenList tl)
-{
- ffesttTokenItem ti;
-
- for (ti = tl->first; ti != (ffesttTokenItem) &tl->first; ti = ti->next)
- {
- if (ti != tl->first)
- fputc (',', dmpout);
- switch (ffelex_token_type (ti->t))
- {
- case FFELEX_typeNUMBER:
- case FFELEX_typeNAME:
- case FFELEX_typeNAMES:
- fputs (ffelex_token_text (ti->t), dmpout);
- break;
-
- case FFELEX_typeASTERISK:
- fputc ('*', dmpout);
- break;
-
- default:
- assert (FALSE);
- fputc ('?', dmpout);
- break;
- }
- }
-}
-#endif
-
/* ffestt_tokenlist_handle -- Handle list of tokens
ffesttTokenList tl;
void ffestt_caselist_append (ffesttCaseList list, bool range, ffebld case1,
ffebld case2, ffelexToken t);
ffesttCaseList ffestt_caselist_create (void);
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
-void ffestt_caselist_dump (ffesttCaseList list);
-#endif
void ffestt_caselist_kill (ffesttCaseList list);
void ffestt_dimlist_append (ffesttDimList list, ffebld lower, ffebld upper,
ffelexToken t);
ffebld *array_size, ffebld *extents,
bool is_ugly_assumed);
ffesttDimList ffestt_dimlist_create (void);
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
-void ffestt_dimlist_dump (ffesttDimList list);
-#endif
void ffestt_dimlist_kill (ffesttDimList list);
ffestpDimtype ffestt_dimlist_type (ffesttDimList dims, bool is_ugly_assumed);
void ffestt_exprlist_append (ffesttExprList list, ffebld expr, ffelexToken t);
ffesttExprList ffestt_exprlist_create (void);
void ffestt_exprlist_drive (ffesttExprList list, void (*fn) (ffebld, ffelexToken));
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
-void ffestt_exprlist_dump (ffesttExprList list);
-#endif
void ffestt_exprlist_kill (ffesttExprList list);
ffesttFormatList ffestt_formatlist_append (ffesttFormatList list);
ffesttFormatList ffestt_formatlist_create (ffesttFormatList parent,
ffelexToken t);
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
-void ffestt_formatlist_dump (ffesttFormatList list);
-#endif
void ffestt_formatlist_kill (ffesttFormatList list);
void ffestt_implist_append (ffesttImpList list, ffelexToken first,
ffelexToken last);
ffesttImpList ffestt_implist_create (void);
void ffestt_implist_drive (ffesttImpList list, void (*fn) (ffelexToken, ffelexToken));
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
-void ffestt_implist_dump (ffesttImpList list);
-#endif
void ffestt_implist_kill (ffesttImpList list);
void ffestt_tokenlist_append (ffesttTokenList list, ffelexToken t);
ffesttTokenList ffestt_tokenlist_create (void);
void ffestt_tokenlist_drive (ffesttTokenList list, void (*fn) (ffelexToken));
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
-void ffestt_tokenlist_dump (ffesttTokenList list);
-#endif
ffelexHandler ffestt_tokenlist_handle (ffesttTokenList list,
ffelexHandler handler);
void ffestt_tokenlist_kill (ffesttTokenList list);
int uses_; /* # uses (new+use-kill calls). */
ffestvState state_;
int substate_; /* Used on a per-block-state basis. */
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
struct nesting *do_hook_; /* backend id for given loop (EXIT/CYCLE). */
tree do_tvar_; /* tree form of do_iter_var. */
tree do_incr_saved_; /* tree SAVED_EXPR of incr expr. */
bool select_break_; /* TRUE when CASE should start with gen
"break;". */
int ifthen_fake_else_; /* Number of fake `else' introductions. */
-#endif /* FFECOM_targetCURRENT == FFECOM_targetGCC*/
};
struct _ffestw_case_
/* Choose how to handle global symbols here. */
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
-#define FFESYMBOL_globalCURRENT_ FFESYMBOL_globalPROGUNIT_
-#elif FFECOM_targetCURRENT == FFECOM_targetGCC
/* Would be good to understand why PROGUNIT in this case too.
(1995-08-22). */
#define FFESYMBOL_globalCURRENT_ FFESYMBOL_globalPROGUNIT_
-#else
-#error
-#endif
/* Choose how to handle memory pools based on global symbol stuff. */
ffename_space_drive_symbol (ffesymbol_sfunc_, fn);
}
-/* Dump info on the symbol for debugging purposes. */
-
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
-void
-ffesymbol_dump (ffesymbol s)
-{
- ffeinfoKind k;
- ffeinfoWhere w;
-
- assert (s != NULL);
-
- if (ffeinfo_size (s->info) != FFETARGET_charactersizeNONE)
- fprintf (dmpout, "%s:%d%s%s*%" ffetargetCharacterSize_f "u",
- ffesymbol_text (s),
- (int) ffeinfo_rank (s->info),
- ffeinfo_basictype_string (ffeinfo_basictype (s->info)),
- ffeinfo_kindtype_string (ffeinfo_kindtype (s->info)),
- ffeinfo_size (s->info));
- else
- fprintf (dmpout, "%s:%d%s%s",
- ffesymbol_text (s),
- (int) ffeinfo_rank (s->info),
- ffeinfo_basictype_string (ffeinfo_basictype (s->info)),
- ffeinfo_kindtype_string (ffeinfo_kindtype (s->info)));
- if ((k = ffeinfo_kind (s->info)) != FFEINFO_kindNONE)
- fprintf (dmpout, "/%s", ffeinfo_kind_string (k));
- if ((w = ffeinfo_where (s->info)) != FFEINFO_whereNONE)
- fprintf (dmpout, "@%s", ffeinfo_where_string (w));
-
- if ((s->generic != FFEINTRIN_genNONE)
- || (s->specific != FFEINTRIN_specNONE)
- || (s->implementation != FFEINTRIN_impNONE))
- fprintf (dmpout, "{%s:%s:%s}",
- ffeintrin_name_generic (s->generic),
- ffeintrin_name_specific (s->specific),
- ffeintrin_name_implementation (s->implementation));
-}
-#endif
-
/* Produce generic error message about a symbol.
For now, just output error message using symbol's name and pointing to
ffesymbol_error (s, NULL);
}
-/* Report info on the symbol for debugging purposes. */
-
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
-ffesymbol
-ffesymbol_report (ffesymbol s)
-{
- ffeinfoKind k;
- ffeinfoWhere w;
-
- assert (s != NULL);
-
- if (s->reported)
- return s;
-
- s->reported = TRUE;
-
- if (ffeinfo_size (s->info) != FFETARGET_charactersizeNONE)
- fprintf (dmpout, "\"%s\": %s %s %d%s%s*%" ffetargetCharacterSize_f "u",
- ffesymbol_text (s),
- ffesymbol_state_string (s->state),
- ffesymbol_attrs_string (s->attrs),
- (int) ffeinfo_rank (s->info),
- ffeinfo_basictype_string (ffeinfo_basictype (s->info)),
- ffeinfo_kindtype_string (ffeinfo_kindtype (s->info)),
- ffeinfo_size (s->info));
- else
- fprintf (dmpout, "\"%s\": %s %s %d%s%s",
- ffesymbol_text (s),
- ffesymbol_state_string (s->state),
- ffesymbol_attrs_string (s->attrs),
- (int) ffeinfo_rank (s->info),
- ffeinfo_basictype_string (ffeinfo_basictype (s->info)),
- ffeinfo_kindtype_string (ffeinfo_kindtype (s->info)));
- if ((k = ffeinfo_kind (s->info)) != FFEINFO_kindNONE)
- fprintf (dmpout, "/%s", ffeinfo_kind_string (k));
- if ((w = ffeinfo_where (s->info)) != FFEINFO_whereNONE)
- fprintf (dmpout, "@%s", ffeinfo_where_string (w));
- fputc ('\n', dmpout);
-
- if (s->dims != NULL)
- {
- fprintf (dmpout, " dims: ");
- ffebld_dump (s->dims);
- fputs ("\n", dmpout);
- }
-
- if (s->extents != NULL)
- {
- fprintf (dmpout, " extents: ");
- ffebld_dump (s->extents);
- fputs ("\n", dmpout);
- }
-
- if (s->dim_syms != NULL)
- {
- fprintf (dmpout, " dim syms: ");
- ffebld_dump (s->dim_syms);
- fputs ("\n", dmpout);
- }
-
- if (s->array_size != NULL)
- {
- fprintf (dmpout, " array size: ");
- ffebld_dump (s->array_size);
- fputs ("\n", dmpout);
- }
-
- if (s->init != NULL)
- {
- fprintf (dmpout, " init-value: ");
- if (ffebld_op (s->init) == FFEBLD_opANY)
- fputs ("<any>\n", dmpout);
- else
- {
- ffebld_dump (s->init);
- fputs ("\n", dmpout);
- }
- }
-
- if (s->accretion != NULL)
- {
- fprintf (dmpout, " accretion (%" ffetargetOffset_f "d left): ",
- s->accretes);
- ffebld_dump (s->accretion);
- fputs ("\n", dmpout);
- }
- else if (s->accretes != 0)
- fprintf (dmpout, " accretes!! = %" ffetargetOffset_f "d left\n",
- s->accretes);
-
- if (s->dummy_args != NULL)
- {
- fprintf (dmpout, " dummies: ");
- ffebld_dump (s->dummy_args);
- fputs ("\n", dmpout);
- }
-
- if (s->namelist != NULL)
- {
- fprintf (dmpout, " namelist: ");
- ffebld_dump (s->namelist);
- fputs ("\n", dmpout);
- }
-
- if (s->common_list != NULL)
- {
- fprintf (dmpout, " common-list: ");
- ffebld_dump (s->common_list);
- fputs ("\n", dmpout);
- }
-
- if (s->sfunc_expr != NULL)
- {
- fprintf (dmpout, " sfunc expression: ");
- ffebld_dump (s->sfunc_expr);
- fputs ("\n", dmpout);
- }
-
- if (s->is_save)
- {
- fprintf (dmpout, " SAVEd\n");
- }
-
- if (s->is_init)
- {
- fprintf (dmpout, " initialized\n");
- }
-
- if (s->do_iter)
- {
- fprintf (dmpout, " DO-loop iteration variable (currently)\n");
- }
-
- if (s->explicit_where)
- {
- fprintf (dmpout, " Explicit INTRINSIC/EXTERNAL\n");
- }
-
- if (s->namelisted)
- {
- fprintf (dmpout, " Namelisted\n");
- }
-
- if (s->common != NULL)
- {
- fprintf (dmpout, " COMMON area: %s\n", ffesymbol_text (s->common));
- }
-
- if (s->equiv != NULL)
- {
- fprintf (dmpout, " EQUIVALENCE information: ");
- ffeequiv_dump (s->equiv);
- fputs ("\n", dmpout);
- }
-
- if (s->storage != NULL)
- {
- fprintf (dmpout, " Storage: ");
- ffestorag_dump (s->storage);
- fputs ("\n", dmpout);
- }
-
- return s;
-}
-#endif
-
-/* Report info on the symbols. */
-
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
-void
-ffesymbol_report_all ()
-{
- ffename_space_drive_symbol (ffesymbol_sfunc_, ffesymbol_report);
- ffename_space_drive_symbol (ffesymbol_local_, ffesymbol_report);
- ffename_space_drive_symbol (ffesymbol_global_, ffesymbol_report);
-}
-#endif
-
/* Resolve symbol that has become known intrinsic or non-intrinsic. */
void
void ffesymbol_drive (ffesymbol (*fn) (ffesymbol));
void ffesymbol_drive_sfnames (ffesymbol (*fn) (ffesymbol));
#define ffesymbol_dummyargs(s) ((s)->dummy_args)
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
-void ffesymbol_dump (ffesymbol s);
-#endif
void ffesymbol_error (ffesymbol s, ffelexToken t);
#define ffesymbol_equiv(s) ((s)->equiv)
#define ffesymbol_explicitwhere(s) ((s)->explicit_where)
#define ffesymbol_ptr_to_namelist(s) (&(s)->namelist)
#define ffesymbol_rank(s) ffeinfo_rank((s)->info)
void ffesymbol_reference (ffesymbol s, ffelexToken t, bool explicit);
-#if FFECOM_targetCURRENT == FFECOM_targetFFE
-ffesymbol ffesymbol_report (ffesymbol s);
-void ffesymbol_report_all (void);
-#endif
void ffesymbol_resolve_intrin (ffesymbol s);
void ffesymbol_retract (bool retract);
bool ffesymbol_retractable (void);
/* Define macros. */
-#if BUILT_FOR_280
-#define FFETARGET_REAL_VALUE_FROM_INT_(resr, lf, kt) \
- REAL_VALUE_FROM_INT (resr, (long) lf, (long) ((lf < 0) ? -1 : 0), ((kt == 1) ? SFmode : DFmode))
-#else
-#define FFETARGET_REAL_VALUE_FROM_INT_(resr, lf, kt) \
- REAL_VALUE_FROM_INT (resr, (long) lf, (long) ((lf < 0) ? -1 : 0))
-#endif
+#define FFETARGET_REAL_VALUE_FROM_INT_(resr, lf, kt) \
+ REAL_VALUE_FROM_INT (resr, (long) lf, (long) ((lf < 0) ? -1 : 0), \
+ ((kt == 1) ? SFmode : DFmode))
#ifdef REAL_ARITHMETIC
#define ffetarget_add_complex1(res,l,r) \
#include "symbol.h"
#include "target.h"
#include "where.h"
-#if FFECOM_targetCURRENT == FFECOM_targetGCC
#include "flags.h"
#include "toplev.h"
-#endif
/* Externals defined here. */
projects / gcc.git / commitdiff